Phsu 0.1.0.0 → 0.1.0.1
raw patch · 7 files changed
+853/−4 lines, 7 files
Files
- Phsu.cabal +5/−4
- src/BoilerplateDB.hs +202/−0
- src/DBSupport.hs +67/−0
- src/Diffs.hs +260/−0
- src/PassGen.hs +85/−0
- src/Search.hs +198/−0
- src/Template.hs +36/−0
Phsu.cabal view
@@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.1.0.0+version: 0.1.0.1 -- A short (one-line) description of the package. synopsis: Personal Happstack Server Utils@@ -34,6 +34,8 @@ -- patches. maintainer: utkarsh.lath@gmail.com +Extra-Source-Files: src/*.hs+ -- A copyright notice. -- copyright: @@ -54,10 +56,9 @@ main-is: Main.hs -- Modules included in this executable, other than Main.- -- other-modules: - + -- other-modules: -- LANGUAGE extensions used by modules in this package.- -- other-extensions: + other-extensions: DeriveDataTypeable, FlexibleContexts, GeneralizedNewtypeDeriving, MultiParamTypeClasses, OverloadedStrings, ScopedTypeVariables, TemplateHaskell, TypeFamilies, FlexibleInstances -- Other library packages from which modules are imported. build-depends: base<5, happstack-server, happstack-server-tls, acid-state, blaze-html, text, mtl, containers, network, regex-base, lifted-base, monad-control, safecopy, filepath, aeson, time, old-locale, blaze-markup, process, curl, temporary, MissingH, regex-pcre, friendly-time, string-conversions
+ src/BoilerplateDB.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts+ , GeneralizedNewtypeDeriving, MultiParamTypeClasses+ , OverloadedStrings, ScopedTypeVariables, TemplateHaskell+ , TypeFamilies, FlexibleInstances #-}++module BoilerplateDB (withAcid, runApp, App,+ URLSubDb, URLSub, exportURLSub, exportAllURLSubRules, exportUpdateURLSub, exportAddURLSub, exportRemoveURLSub, exportHitRule, exportReorderURLSub,+ regex, substitute, ruleId, hits,+ GithubSettings, exportGithubSetting, exportUpdateGithubSetting,+ ghHandle, ghToken, allGhUsers+ ) where++import Control.Applicative (Applicative, Alternative, (<$>))+import Control.Exception.Lifted (bracket)+import Control.Monad (MonadPlus)+import Control.Monad.Reader (MonadReader, ReaderT(..), ask)+import Control.Monad.State (modify)+import Control.Monad.Trans (MonadIO(..))+import Control.Monad.Trans.Control (MonadBaseControl)+import Data.Acid (AcidState(..), EventState(..), EventResult(..), Query(..), QueryEvent(..), Update(..), UpdateEvent(..), IsAcidic(..), makeAcidic, openLocalState)+import Data.Acid.Advanced (query', update')+import Data.Acid.Local (createCheckpointAndClose, openLocalStateFrom)+import Data.Data (Data, Typeable)+import Data.IntMap (IntMap)+import Data.IntMap as IntMap+import Data.List (sortBy)+import Data.Map (Map)+import Data.Maybe (fromMaybe, listToMaybe, catMaybes)+import Data.Ord (comparing)+import Data.SafeCopy (SafeCopy, base, deriveSafeCopy)+import Happstack.Server (Happstack, HasRqData, Response, ServerPartT(..), WebMonad, FilterMonad, ServerMonad, mapServerPartT)+import Prelude hiding (head, id)+import System.FilePath ((</>))+import qualified Data.Map as Map++-- begin boiler plate for Acid State+class HasAcidState m st where+ getAcidState :: m (AcidState st)++query :: forall event m.+ ( Functor m+ , MonadIO m+ , QueryEvent event+ , HasAcidState m (EventState event)+ ) =>+ event+ -> m (EventResult event)+query event =+ do as <- getAcidState+ query' (as :: AcidState (EventState event)) event++update :: forall event m.+ ( Functor m+ , MonadIO m+ , UpdateEvent event+ , HasAcidState m (EventState event)+ ) =>+ event+ -> m (EventResult event)+update event =+ do as <- getAcidState+ update' (as :: AcidState (EventState event)) event++-- automatically creates a checkpoint on close+withLocalState+ :: ( MonadBaseControl IO m+ , MonadIO m+ , IsAcidic st+ , Typeable st+ ) =>+ Maybe FilePath -- ^ path to state directory+ -> st -- ^ initial state value+ -> (AcidState st -> m a) -- ^ function which uses the+ -- `AcidState` handle+ -> m a+withLocalState mPath initialState =+ bracket (liftIO $ open initialState)+ (liftIO . createCheckpointAndClose)+ where+ open = maybe openLocalState openLocalStateFrom mPath+-- end boiler plate++-- user defined AcidState (URLSubDb) and functions on them+data URLSub = URLSub { regex :: String+ , substitute:: String+ , hits:: Int+ , ruleId:: Int+ } deriving (Show, Typeable)++data URLSubDb = URLSubDb { allRules :: IntMap URLSub }+ deriving (Typeable)++initialRulesState :: URLSubDb+initialRulesState = URLSubDb { allRules = IntMap.empty }++allURLSubRules :: Query URLSubDb [URLSub]+allURLSubRules =+ sortBy (comparing $ \x -> - (hits x)) . IntMap.elems . allRules <$> ask++addURLSub :: URLSub -> Update URLSubDb ()+addURLSub rule = modify go+ where+ go (URLSubDb db) = URLSubDb $+ case IntMap.maxViewWithKey db of+ Just ((max, _), _) -> IntMap.insert (max + 1) rule{hits=0, ruleId=max+1} db+ Nothing -> IntMap.singleton 1 rule{hits=0, ruleId=1}++removeURLSub :: Int -> Update URLSubDb ()+removeURLSub ruleId = modify go+ where+ go (URLSubDb db) = URLSubDb $ IntMap.delete ruleId db++hitRule :: Int -> Update URLSubDb ()+hitRule ruleId = modify go where+ go (URLSubDb db) = URLSubDb $ IntMap.adjust (\old_rule -> old_rule{hits=(1+(hits old_rule))}) ruleId db+++reorderURLSub :: (IntMap Int) -> Update URLSubDb ()+reorderURLSub mapping = modify go where+ go (URLSubDb db) = URLSubDb . IntMap.fromList . elems . (IntMap.map mymapping) $ db where+ valid = IntMap.null $ IntMap.difference db mapping+ mymapping rule =+ let new_id = if valid then (IntMap.!) mapping $ ruleId rule else ruleId rule+ in (new_id, rule{ruleId=new_id})++updateURLSub :: URLSub -> Update URLSubDb ()+updateURLSub rule = modify go+ where+ go (URLSubDb db) = URLSubDb $ IntMap.adjust (\old_rule -> old_rule{regex=(regex rule), substitute=(substitute rule)}) (ruleId rule) db++$(deriveSafeCopy 0 'base ''URLSub)+$(deriveSafeCopy 0 'base ''URLSubDb)+makeAcidic ''URLSubDb ['allURLSubRules , 'addURLSub, 'removeURLSub, 'updateURLSub, 'hitRule, 'reorderURLSub]++exportAllURLSubRules:: (HasAcidState m URLSubDb, MonadIO m, Functor m) => m (EventResult AllURLSubRules)+exportAllURLSubRules = query AllURLSubRules++exportUpdateURLSub x = BoilerplateDB.update $ UpdateURLSub x+exportAddURLSub x = BoilerplateDB.update $ AddURLSub x+exportRemoveURLSub x = BoilerplateDB.update $ RemoveURLSub x+exportHitRule x = BoilerplateDB.update $ HitRule x+exportReorderURLSub x = BoilerplateDB.update $ ReorderURLSub x+exportURLSub r s i j = URLSub r s i j+-- end user defined AcidState URLSubDb++-- begin user defined AcidState GithubSettings+data GithubSettings = GithubSettings {+ ghHandle :: Maybe String,+ ghToken :: Maybe String,+ allGhUsers :: Maybe (Map String [String])+ } deriving (Show, Typeable)++initialGithubState :: GithubSettings+initialGithubState = GithubSettings { ghHandle = Nothing, ghToken = Nothing, allGhUsers = Just Map.empty }++ghSetting :: Query GithubSettings GithubSettings+ghSetting = ask++updateGithubSetting :: GithubSettings -> Update GithubSettings ()+updateGithubSetting setting = modify go+ where+ go originalSetting = originalSetting {ghHandle = extract ghHandle, ghToken = extract ghToken, allGhUsers = listToMaybe . catMaybes $ [allGhUsers setting, allGhUsers originalSetting]} where+ extract h = listToMaybe . catMaybes $ [h setting, h originalSetting]++$(deriveSafeCopy 0 'base ''GithubSettings)+makeAcidic ''GithubSettings ['ghSetting, 'updateGithubSetting]++exportGithubSetting:: (HasAcidState m GithubSettings, MonadIO m, Functor m) => m (EventResult GhSetting)+exportGithubSetting = query GhSetting+exportUpdateGithubSetting x = BoilerplateDB.update $ UpdateGithubSetting x+-- end user defined AcidState GithubSettings++-- boiler-plate - bundle up into an Acid+data Acid = Acid+ { urlSubRules :: AcidState URLSubDb,+ githubSettings :: AcidState GithubSettings }++withAcid :: Maybe FilePath -> (Acid -> IO a) -> IO a+withAcid mBasePath action =+ let basePath = fromMaybe "state" mBasePath+ rulesPath = Just $ basePath </> "rules"+ githubPath = Just $ basePath </> "github_settings"+ in withLocalState rulesPath initialRulesState $ \c ->+ withLocalState githubPath initialGithubState $ \d ->+ action (Acid c d)+-- end boiler-plate++-- more boiler plate, define an App+newtype App a = App { unApp :: ServerPartT (ReaderT Acid IO) a }+ deriving ( Functor, Alternative, Applicative, Monad+ , MonadPlus, MonadIO, HasRqData, ServerMonad+ , WebMonad Response, FilterMonad Response+ , Happstack, MonadReader Acid+ )++runApp :: Acid -> App a -> ServerPartT IO a+runApp acid (App sp) =+ mapServerPartT (flip runReaderT acid) sp+-- end boiler plate: define an App++instance HasAcidState App URLSubDb where getAcidState = urlSubRules <$> ask+instance HasAcidState App GithubSettings where getAcidState = githubSettings <$> ask
+ src/DBSupport.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts+ , GeneralizedNewtypeDeriving, MultiParamTypeClasses+ , OverloadedStrings, ScopedTypeVariables, TemplateHaskell+ , TypeFamilies, FlexibleInstances #-}+module Main where+import Control.Applicative+import Control.Monad.Reader (ask)+import Control.Monad.State (modify)+import Data.Acid+import Data.Function+import Data.IntMap (IntMap, delete, adjust)+import Data.List+import Data.Ord+import Data.SafeCopy+import Data.Time+import Data.Typeable+import qualified Data.IntMap as IntMap++data URLSub = URLSub { regex :: String+ , substitute:: String+ , hits:: Int+ , ruleId:: Int+ } deriving (Show, Typeable)++data URLSubDb = URLSubDb { allRules :: IntMap URLSub }+ deriving (Typeable)++allURLSubRules :: Query URLSubDb [URLSub]+allURLSubRules =+ sortBy (comparing $ \x -> - (hits x)) . IntMap.elems . allRules <$> ask++addURLSub :: URLSub -> Update URLSubDb ()+addURLSub rule = modify go+ where+ go (URLSubDb db) = URLSubDb $+ case IntMap.maxViewWithKey db of+ Just ((max, _), _) -> IntMap.insert (max + 1) rule{hits=0, ruleId=max+1} db+ Nothing -> IntMap.singleton 1 rule{hits=0, ruleId=1}++removeURLSub :: Int -> Update URLSubDb ()+removeURLSub ruleId = modify go+ where+ go (URLSubDb db) = URLSubDb $ IntMap.delete ruleId db++updateURLSub :: URLSub -> Update URLSubDb ()+updateURLSub rule = modify go+ where+ go (URLSubDb db) = URLSubDb $ IntMap.adjust (\old_rule -> old_rule{regex=(regex rule), substitute=(substitute rule)}) (ruleId rule) db++$(deriveSafeCopy 0 'base ''URLSub)+$(deriveSafeCopy 0 'base ''URLSubDb)+makeAcidic ''URLSubDb ['allURLSubRules , 'addURLSub, 'removeURLSub, 'updateURLSub]++main :: IO ()+main = do+ state <- openLocalState (URLSubDb IntMap.empty)++ -- Record a new failure+ -- update state (AddURLSub $ URLSub "TEST" "Sub" 9 4)+ -- update state (RemoveURLSub 5)+ -- update state (UpdateURLSub $ URLSub{regex="regex", substitute="Trauma", hits=4, ruleId=10})+ update state (AddURLSub $ URLSub{regex="c\\s?([0-9]*)L?", substitute="https://console.zenefits.com/console/company/\\1", hits=4, ruleId=10})++ -- Query for all failures+ allRules <- query state AllURLSubRules++ mapM_ print allRules
+ src/Diffs.hs view
@@ -0,0 +1,260 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts+ , GeneralizedNewtypeDeriving, MultiParamTypeClasses+ , OverloadedStrings, ScopedTypeVariables, TemplateHaskell+ , TypeFamilies, FlexibleInstances, DeriveGeneric #-}++module Diffs (diffSettings, serveDiff) where+import BoilerplateDB (App, GithubSettings, exportGithubSetting, exportUpdateGithubSetting, ghHandle, ghToken, allGhUsers)+import Control.Applicative (optional, (<$>))+import Control.Concurrent.MVar (takeMVar)+import Control.Monad (forM_, when)+import Control.Monad.Trans (MonadIO(..))+import Data.Aeson (decode, FromJSON(..), Value(..))+import Data.List (sortBy)+import Data.List.Utils (startswith)+import Data.Maybe (fromMaybe, fromJust)+import Data.Ord (comparing)+import Data.String.Conversions (cs)+import Data.Text (Text)+import Data.Time.Clock (UTCTime, getCurrentTime)+import Data.Time.Format (parseTime)+import Data.Time.Format.Human (humanReadableTime')+import GHC.Generics+import Happstack.Server+import Network.Curl (curlGetString)+import System.Locale (defaultTimeLocale)+import Template (template, myPolicy)+import Text.Blaze.Html5 (Html, (!), toHtml, toValue)+import Text.Blaze.Html5.Attributes (action, size, type_, value)+import Text.Blaze.Internal(AttributeValue)+import qualified Data.Map as Map+import qualified Network.Curl.Opts as CurlOpts+import qualified Text.Blaze.Html5 as H+import qualified Text.Blaze.Html5.Attributes as A++tv :: String -> AttributeValue+tv x = toValue x++th :: String -> Html+th x = toHtml x++renderRepo (r, users) = do+ H.td $ do+ H.a ! A.href (tv $ "https://github.com/"++r) $ do+ (th $ r ++ " (" ++ (show.length $ users) ++" users)")+ H.td $ do+ H.a ! A.href "#"+ ! A.onclick (tv ("delRepo(\""++r++"\")")) $ do+ th "remove"++serveDiffSettings :: App Response+serveDiffSettings = do+ gh <- exportGithubSetting+ ok $+ template "Diff Settings" $ do+ H.script ! A.type_ (tv "text/javascript") $ "function delRepo(r) { \+ \ var myForm = document.createElement(\"form\");\+ \ op=document.createElement(\"input\");\+ \ op.name=\"op\"; op.value=\"remove\";\+ \ repo=document.createElement(\"input\");\+ \ repo.name=\"repo\"; repo.value=r;\+ \ myForm.action = \"/diff-settings\";\+ \ myForm.appendChild(op); myForm.appendChild(repo);\+ \ myForm.method=\"POST\"; myForm.submit(); }"+ H.body $ do+ H.h1 . th $"Settings"+ H.form ! action "/diff-settings" ! A.method (tv "POST") $ do+ H.table $ do+ H.thead $ do+ H.td ! A.colspan (tv "2")+ ! A.style (toValue ("padding-left:80px"::String)) $ do+ H.b $ th "Github Profile"+ H.tbody $ do+ H.tr $ do+ H.td $ H.label . th $ "Github Handle"+ H.td $ do+ H.input ! type_ "text" ! A.name "handle" ! size "20" ! value (tv.(fromMaybe "").ghHandle $ gh)+ H.tr $ do+ H.td $ do+ H.a ! A.href (tv "https://github.com/settings/tokens") $ th "Access Token"+ H.td $ H.input ! type_ "text" ! A.name "token" ! size "20"+ H.tfoot $ do+ H.td ! A.colspan (tv "2") $ do+ H.button ! A.name "op" ! value (tv "profile") $ th "Save"+ H.form ! action "/diff-settings" ! A.method (tv "POST") $ do+ H.table $ do+ H.thead $ do+ H.td ! A.colspan (tv "2")+ ! A.style (toValue ("padding-left:80px"::String)) $ do+ H.b $ th "Github Repositories"+ H.tbody $ forM_ (Map.toList . fromJust . allGhUsers $ gh) (H.tr . renderRepo)+ H.tfoot $ do+ H.td ! A.colspan (tv "2") $ do+ H.label . th $ "Add repo: "+ H.input ! type_ "text" ! A.name "repo" ! size "30"+ H.button ! A.name "op" ! value (tv "repo") $ th "Add"++data RepoUser = RepoUser { login :: !Text } deriving (Show, Generic, Eq)+instance FromJSON RepoUser++type Opts = [CurlOpts.CurlOption]++extractPage :: (FromJSON a) => Int -> Opts -> String -> IO [a]+extractPage p opts url = (fromJust.decode.cs.snd) <$> (curlGetString (url++"&page="++(show p)) opts)++extractPages :: (FromJSON a) => Opts -> String -> IO [a]+extractPages opts url = go [1..] where+ go (x:xs) = do+ lst <- (extractPage x opts url)+ case lst of+ [] -> return []+ _ -> ((++) lst) <$> (go xs)++getCurlOpts :: GithubSettings -> Opts+getCurlOpts ghs =+ let h = fromJust $ ghHandle ghs; t = fromJust $ ghToken ghs+ in [CurlOpts.CurlUserPwd $ h++":"++t, CurlOpts.CurlUserAgent "curl/7.37.1"]+++getAllRepoUsers :: GithubSettings -> String -> IO [String]+getAllRepoUsers ghs repo = do+ users <- ((extractPages (getCurlOpts ghs) ("https://api.github.com/repos/" ++ repo ++ "/contributors?per_page=100")):: IO [RepoUser])+ return $ map (cs.login) users++addRepo repo = do+ ghs <- exportGithubSetting+ users <- liftIO $ getAllRepoUsers ghs repo+ let mp = allGhUsers ghs in exportUpdateGithubSetting (ghs{allGhUsers=(\m->Map.insert repo users m) <$> mp})++removeRepo repo = do+ ghs <- exportGithubSetting+ let mp = allGhUsers ghs in exportUpdateGithubSetting $ ghs{allGhUsers=(Map.delete repo) <$> mp}++editProfile handle token = do+ ghs <- exportGithubSetting+ exportUpdateGithubSetting (ghs {ghHandle=Just handle, ghToken=Just token})++processEditForm rqmap = do+ case readKey rqmap "op" of+ "repo" -> let repo = readKey rqmap "repo" in addRepo repo+ "profile" -> editProfile (readKey rqmap "handle") (readKey rqmap "token")+ "remove" -> let repo = readKey rqmap "repo" in removeRepo repo++extractStr :: Input -> String+extractStr input = case (inputValue input) of+ Right x -> cs x++readKey reqMap key =+ extractStr (reqMap Map.! key) where++diffSettings :: App Response+diffSettings = do+ m <- rqMethod <$> askRq+ case m of+ GET ->+ serveDiffSettings+ POST -> do+ decodeBody myPolicy+ all <- rqInputsBody <$> askRq+ dat <- Map.fromList <$> (liftIO $ takeMVar all)+ processEditForm dat+ serveDiffSettings -- $ (show.prepareEdits) dat++data PullRequestLabel = PullRequestLabel {+ name :: !Text,+ color:: !Text+} deriving (Show, Generic)+instance FromJSON PullRequestLabel++data PullRequest = PullRequest {+ number :: Int,+ title :: !Text,+ user :: RepoUser,+ labels:: [PullRequestLabel],+ html_url :: !Text,+ state :: !Text,+ created_at :: !Text,+ updated_at :: !Text,+ assignee:: Maybe RepoUser,+ body :: !Text+} deriving (Show, Generic)+instance FromJSON PullRequest++toTime :: String -> UTCTime+toTime = fromJust . (parseTime defaultTimeLocale "%FT%X%QZ")++subPR :: PullRequestsAsItems -> PullRequestsAsItems -> PullRequestsAsItems+subPR x y =+ let+ mp x = Map.fromList (map (\t -> (number t, t)) $ items x)+ in+ PullRequestsAsItems { items = Map.elems $ Map.difference (mp x) (mp y)}+++data PullRequestsAsItems = PullRequestsAsItems { items :: [PullRequest] } deriving (Show, Generic)+instance FromJSON PullRequestsAsItems++curl :: (FromJSON a) => String -> Opts -> IO a+curl url opts = (fromJust.decode.cs.snd) <$> (curlGetString url opts)++renderLabel :: PullRequestLabel -> Html+renderLabel label = do+ H.label ! A.style (tv $ "background-color:#"++(cs.color $ label)) $ th ((cs.name) label)++renderPR :: UTCTime -> PullRequest -> Html+renderPR time pr = do+ H.td ! A.style (tv "width:80%; padding-top: 10px; border: 0px; padding-bottom: 10px") $ do+ H.hr ! A.style (tv "border-bottom: 1px solid #000;")+ H.p $ do+ H.b $ (th . show . number $ pr)+ H.a ! A.style (tv $ "padding-left: 7px;") ! A.href (tv.cs $ html_url pr) $ do+ H.b $ th (cs.title $ pr)+ H.p $ do+ forM_ (labels pr) $ renderLabel+ H.label ! A.style (tv $ "padding-left: 7px;") $ th "Reviewers:"+ when (assignee pr /= Nothing) (H.a ! A.href (tv ("https://github.com/"++(cs.login.fromJust.assignee $ pr))) $ th (cs.login.fromJust.assignee $ pr))+ H.td ! A.style (tv "width:20%; border: 0px") $ do+ H.hr ! A.style (tv "border-bottom: 1px solid #000;")+ H.p $ do+ H.label $ th (humanReadableTime' time $ (toTime . cs . updated_at) pr)+ H.p $ do+ H.label $ th "Author: "+ H.a ! A.href (tv ("https://github.com/"++(cs.login.user $ pr))) $ th (cs.login.user $ pr)++servePRList :: UTCTime -> String -> PullRequestsAsItems -> Html+servePRList time heading prs = do+ H.p $ do+ H.table ! A.style (tv "width:100%; border:0; border-style: hidden; margin: 0;") $ do+ H.thead $ do+ H.td ! A.colspan (tv "2")+ ! A.style (tv "border: 0px; paddin-left: 80px") $ do+ H.h1 $ toHtml heading+ H.tbody $ do+ forM_ (reverse.sortBy (comparing $ \x -> updated_at x) $ items prs) $ H.tr . (renderPR time)++serveDiffForHandle :: GithubSettings -> String -> App Response+serveDiffForHandle ghs handle =+ let+ opts = getCurlOpts ghs+ url filter = "https://api.github.com/search/issues?q="++filter++"+state:open+type:pr"+ in do+ assigned <- liftIO ((curl (url ("assignee:"++handle)) $ opts)::IO PullRequestsAsItems)+ authored <- liftIO ((curl (url ("author:"++handle)) $ opts)::IO PullRequestsAsItems)+ mentions <- liftIO ((curl (url ("involves:"++handle)) $ opts)::IO PullRequestsAsItems)+ time <- liftIO getCurrentTime+ ok $+ template "Diffs" $ do+ H.body $ do+ H.form ! A.action (tv "#") ! A.method (tv "GET") $ do+ H.label . th $ "Diffs for user :"+ H.input ! type_ "text" ! (A.name . tv) "handle" ! size "20" ! value (tv handle)+ H.button ! A.name "op" ! value (tv "handle") $ th "View"+ servePRList time "Everything assigned to you" $ subPR assigned authored+ servePRList time "Everything authored by you" $ authored+ servePRList time "Everything you are CCd on" $ mentions `subPR` authored `subPR` assigned++serveDiff :: App Response+serveDiff = do+ ghs <- exportGithubSetting+ handle <- (\x -> (fromMaybe (fromJust $ ghHandle ghs)) (cs <$> x)) <$> (optional $ lookText "handle")+ serveDiffForHandle ghs handle
+ src/PassGen.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE OverloadedStrings #-}+module PassGen (servePassGen) where++import BoilerplateDB (App)+import Control.Applicative (optional, (<$>))+import Control.Monad.Trans (MonadIO(..))+import Data.Char (toLower)+import Data.List.Utils (startswith)+import Data.Maybe (fromMaybe)+import Data.String.Conversions (cs)+import Happstack.Server+import System.IO.Temp+import System.Process+import Template(template, myPolicy)+import Text.Blaze.Html5 (Html, (!), toHtml, toValue)+import Text.Blaze.Html5.Attributes (action, name, size, type_, value)+import qualified Text.Blaze.Html5 as H+import qualified Text.Blaze.Html5.Attributes as A++javaCode::String+javaCode = "import java.math.*;import java.util.Random;public class PassGen { static String convert(char A[],String hex) { String s=\"\"; BigInteger b=new BigInteger(hex,16); while(!b.equals(new BigInteger(\"0\"))) { s+=A[b.mod(BigInteger.valueOf(A.length)).intValue()]; b=b.divide(BigInteger.valueOf(A.length)); } return s; } static long rightRotate(long x,int l) { return (x>>l)^((x&((1l<<l)-1))<<(32-l)); } static String preprocess(String a) { String s=\"\"; for(char x=0;x<a.length();x++) { String tt=Integer.toString(a.charAt(x),2); while(tt.length()<7) tt='0'+tt; s+=tt; } String sp=Long.toBinaryString(s.length()); s+=\"1\"; while(s.length()%512!=512-sp.length()) s+=\"0\"; s+=sp; return s; } static String f(long l) { String s = Long.toString(l,16); while(s.length()<8) s=\"0\"+s; return s; } static String[] breakString(String s,int l) { String A[] = new String[1+(s.length()-1)/l]; for(int x=0;x<A.length;x++) { A[x]=s.substring(0,l); s=s.substring(l); } return A; } static String sha1(String s) { long h0=0x67452301l,h1=0xEFCDAB89l,h2=0x98BADCFEl,h3=0x10325476l,h4=0xC3D2E1F0l; s=preprocess(s); String chunks[]=breakString(s,512); for(int x=0;x<chunks.length;x++) { s=chunks[x]; String words[]=breakString(s,32); long w[]=new long[80]; for(int i=0;i<16;i++)w[i]=Long.parseLong(words[i],2); for(int i=16;i<80;i++) { w[i]=w[i-3]^w[i-8]^w[i-14]^w[i-16]; w[i]=rightRotate(w[i],31); } long a=h0,b=h1,c=h2,d=h3,e=h4,f,k; for(int i=0;i<80;i++) { if(i<20) { k = 0x5A827999l; f=(b&c)|((~b)&d); } else if(i<40) { f=b^c^d; k = 0x6ED9EBA1l; } else if(i<60) { f=(b&c)|(b&d)|(c&d); k = 0x8F1BBCDCl; } else { f=b^c^d; k = 0xCA62C1D6l; } long tmp=(((a<<5)^(a>>27))&4294967295l)+f+e+k+w[i]; e=d; d=c; c=(((b<<30)^(b>>2))&4294967295l); b=a; a=tmp&4294967295l; } h0=(h0+a)&4294967295l; h1=(h1+b)&4294967295l; h2=(h2+c)&4294967295l; h3=(h3+d)&4294967295l; h4=(h4+e)&4294967295l; } return f(h0)+f(h1)+f(h2)+f(h3)+f(h4); } static String sha2(String s) { long h[]={ 0x6a09e667l, 0xbb67ae85l, 0x3c6ef372l, 0xa54ff53al, 0x510e527fl, 0x9b05688cl, 0x1f83d9abl, 0x5be0cd19l }, k[]={ 0x428a2f98l, 0x71374491l, 0xb5c0fbcfl, 0xe9b5dba5l, 0x3956c25bl, 0x59f111f1l, 0x923f82a4l, 0xab1c5ed5l, 0xd807aa98l, 0x12835b01l, 0x243185bel, 0x550c7dc3l, 0x72be5d74l, 0x80deb1fel, 0x9bdc06a7l, 0xc19bf174l, 0xe49b69c1l, 0xefbe4786l, 0x0fc19dc6l, 0x240ca1ccl, 0x2de92c6fl, 0x4a7484aal, 0x5cb0a9dcl, 0x76f988dal, 0x983e5152l, 0xa831c66dl, 0xb00327c8l, 0xbf597fc7l, 0xc6e00bf3l, 0xd5a79147l, 0x06ca6351l, 0x14292967l, 0x27b70a85l, 0x2e1b2138l, 0x4d2c6dfcl, 0x53380d13l, 0x650a7354l, 0x766a0abbl, 0x81c2c92el, 0x92722c85l, 0xa2bfe8a1l, 0xa81a664bl, 0xc24b8b70l, 0xc76c51a3l, 0xd192e819l, 0xd6990624l, 0xf40e3585l, 0x106aa070l, 0x19a4c116l, 0x1e376c08l, 0x2748774cl, 0x34b0bcb5l, 0x391c0cb3l, 0x4ed8aa4al, 0x5b9cca4fl, 0x682e6ff3l, 0x748f82eel, 0x78a5636fl, 0x84c87814l, 0x8cc70208l, 0x90befffal, 0xa4506cebl, 0xbef9a3f7l, 0xc67178f2l }; s=preprocess(s); String chunks[]=breakString(s,512); for(int x=0;x<chunks.length;x++) { s=chunks[x]; String words[]=breakString(s,32); long w[]=new long[64]; for(int i=0;i<16;i++) w[i]=Long.parseLong(words[i],2); for(int i=16;i<64;i++) { long s0=rightRotate(w[i-15],7)^rightRotate(w[i-15],18)^(w[i-15]>>3), s1=rightRotate(w[i-2],17)^rightRotate(w[i-2],19)^(w[i-2]>>10); w[i]=(w[i-16]+s0+w[i-7]+s1)&4294967295l; } long a[]=new long[8]; System.arraycopy(h, 0, a, 0, 8); for(int i=0;i<64;i++) { long s0 = rightRotate(a[0],2)^rightRotate(a[0],13)^rightRotate(a[0],22), maj = (a[0]&a[1])^(a[0]&a[2])^(a[1]&a[2]), t2 = (s0+maj)&4294967295l, s1 = rightRotate(a[4],6)^rightRotate(a[4],11)^rightRotate(a[4],25), ch = (a[4]&a[5])^((~a[4])&a[6]), t1 = (a[7]+s1+ch+k[i]+w[i])&4294967295l; a[7]=a[6]; a[6]=a[5]; a[5]=a[4]; a[4]=(a[3]+t1)&4294967295l; a[3]=a[2]; a[2]=a[1]; a[1]=a[0]; a[0]=(t1+t2)&4294967295l; } for(int i=0;i<8;i++) h[i]=(h[i]+a[i])&4294967295l; } String ans=\"\"; for(int x=0;x<8;x++) ans+=f(h[x]); return ans; } static String entwine(String a,String b,java.util.Random r) { boolean b1=true, b2=true; String entwined=\"\"; int id1=0, id2=0; while(b1||b2) { if(r.nextDouble()<a.length()/(a.length()+b.length()+0.0)) entwined+=a.charAt(id1++); else entwined+=b.charAt(id2++); if(id1==a.length()){b1=false;id1=0;} if(id2==b.length()){b2=false;id2=0;} } return entwined; } static int toNum(String s,long l) { return (new BigInteger(PassGen.sha1(s),16)).divide(BigInteger.valueOf(l)).intValue(); } static String processWebsiteName(String Kw2) { Kw2=Kw2.toLowerCase(); if(Kw2.startsWith(\"http:\")||Kw2.startsWith(\"https:\")) while(Kw2.charAt(0)!=':'&&Kw2.charAt(0)!='/') Kw2=Kw2.substring(1); while(Kw2.charAt(0)==':'||Kw2.charAt(0)=='/') Kw2=Kw2.substring(1); Kw2=Kw2.split(\"/\")[0]; return Kw2; } static String generatePassword(String Kw1,String Kw2,int length,char A[]) { int seed=(int)((((length* 786431l+toNum(Kw2,596572387l)*1848l+toNum(Kw1,1645333507l)* 333667l)%3626149l)*2796203l)% 1645333507l); Random r=new java.util.Random(seed); String finalPwd=\"\"; Kw1=entwine(Kw1,Kw2,r); while(length>0) { String sha=PassGen.convert(A,PassGen.sha2(Kw1)); if(length>=sha.length()) { finalPwd+=sha; length-=sha.length(); } else { finalPwd+=PassGen.randomPermutation(sha, r).substring(0,length); length=0; } Kw1=randomPermutation(sha,r); } return finalPwd; } static String randomPermutation(String s,java.util.Random r) { String s1=\"\"; while(s.length()>0) { int x=r.nextInt(s.length()); s1+=s.charAt(x); s=s.substring(0,x)+s.substring(x+1); } return s1; } public static void main(String args[]) { char A[]=new char[64]; for(int x='0';x<='9';x++) A[x-'0']=(char)x; for(int x='A';x<='Z';x++) { A[x-'A'+10]=(char)x; A[x-'A'+36]=(char)(x+32); } A[62]='<'; A[63]='>'; if (args.length != 3) { System.err.println(\"Usage: COMMAND website password length\"); System.exit(1); } String site = PassGen.processWebsiteName(args[0]); int length = Integer.parseInt(args[2]); System.out.print(PassGen.generatePassword(args[1], site, length, A)); }}"++exec site pwd len dir =+ let codeFile = dir ++ "/PassGen.java"+ in do+ writeFile codeFile javaCode+ readProcess "javac" [codeFile] ""+ pw <- readProcess "java" ["-cp", dir, "PassGen", site, pwd, len] ""+ return pw++getPassword = do+ pwd <- cs <$> lookText "password"+ site <- (processSiteName . (map toLower) . cs) <$> lookText "site"+ len <- cs <$> lookText "length"+ liftIO . (withTempDirectory "/tmp/" "src_temp") $ exec site pwd len++processSiteSuffix :: String -> String+processSiteSuffix = (takeWhile ((/=) '/')) . (dropWhile ((flip elem) ":/"))+processSiteName:: String -> String+processSiteName site+ | startswith "http:" site || startswith "https:" site = processSiteSuffix . (dropWhile ((/=) ':')) $ site+ | otherwise = processSiteSuffix site++passwordJs :: Maybe String -> String+passwordJs Nothing = ""+passwordJs (Just p) = "showPassword('" ++ p ++ "')"++serve :: Maybe String -> App Response+serve p = do+ site <- (processSiteName . (map toLower) . cs . (fromMaybe "")) <$> (optional $ lookText "site")+ len <- (cs . (fromMaybe "14")) <$> (optional $ lookText "length")+ ok . (template "Password generator") $ do+ H.script ! A.type_ (toValue ("text/javascript"::String)) $ "function showPassword(x) { window.prompt(\"password\", x); }"+ H.body ! A.onload (toValue $ passwordJs p) $ do+ H.h1 . toHtml $ ("Password generator"::String)+ H.form ! action "/password" ! 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 ("Generate Password"::String)+ H.tbody $ do+ H.tr $ do+ H.td $ H.label . toHtml $ ("Website"::String)+ H.td $ H.input ! type_ "text" ! (name . toValue) ("site"::String) ! value (toValue site) ! size "120"+ H.tr $ do+ H.td $ H.label . toHtml $ ("Password"::String)+ H.td $ H.input ! type_ "password" ! (name . toValue) ("password"::String) ! size "25"+ H.tr $ do+ H.td $ H.label . toHtml $ ("Length"::String)+ H.td $ H.input ! type_ "text" ! (name . toValue) ("length"::String) ! value (toValue (len::String)) ! size "3"+ H.tfoot $ do+ H.td ! A.colspan (toValue ("2"::String)) $ do+ H.button ! name "op" $ toHtml ("Generate Password"::String)++servePassGen :: App Response+servePassGen = do+ m <- rqMethod <$> askRq+ case m of+ GET ->+ serve Nothing+ POST -> do+ decodeBody myPolicy+ p <- getPassword+ serve $ Just p
+ src/Search.hs view
@@ -0,0 +1,198 @@+{-# 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
+ src/Template.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE OverloadedStrings #-}+module Template(template, myPolicy) where++import Control.Monad.Trans (MonadIO(..))+import Data.String.Conversions (cs)+import Data.Text (Text)+import Happstack.Server+import Text.Blaze.Html5 (Html, (!), toHtml)+import qualified Text.Blaze.Html5 as H+import qualified Text.Blaze.Html5.Attributes as A++template :: Text -> Html -> Response+template title body = toResponse $+ H.html $ do+ H.head $ do+ H.title (toHtml title)+ H.style $ H.toHtml $ unlines [ "table { margin: 0 auto; border-collapse: collapse; font-family: 'sans-serif'; }"+ , "table, th, td { border: 1px solid #353948; }"+ , "td.size { text-align: right; font-size: 0.7em; }"+ , "td.date { text-align: right; font-size: 0.7em; }"+ , "td { padding-right: 1em; padding-left: 1em; }"+ , "th.first { background-color: white; }"+ , "td.first { padding-right: 0; padding-left: 0; text-align: center }"+ , "tr { background-color: white; }"+ , "tr.alt { background-color: #A3B5BA}"+ , "th { background-color: #3C4569; color: white; font-size: 1.125em; }"+ , "h1 { width: 760px; margin: 1.4em auto; font-size: 1em; font-family: sans-serif }"+ , "img { width: 20px }"+ , "a { text-decoration: none }"+ ]+ H.body $ do+ body+ H.p $ H.a ! A.href ("/") $ "back home"++myPolicy :: BodyPolicy+myPolicy = (defaultBodyPolicy "/tmp/" 0 10000 10000)