diff --git a/Phsu.cabal b/Phsu.cabal --- a/Phsu.cabal +++ b/Phsu.cabal @@ -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 diff --git a/src/BoilerplateDB.hs b/src/BoilerplateDB.hs new file mode 100644 --- /dev/null +++ b/src/BoilerplateDB.hs @@ -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 diff --git a/src/DBSupport.hs b/src/DBSupport.hs new file mode 100644 --- /dev/null +++ b/src/DBSupport.hs @@ -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 diff --git a/src/Diffs.hs b/src/Diffs.hs new file mode 100644 --- /dev/null +++ b/src/Diffs.hs @@ -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 diff --git a/src/PassGen.hs b/src/PassGen.hs new file mode 100644 --- /dev/null +++ b/src/PassGen.hs @@ -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<>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>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()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 diff --git a/src/Search.hs b/src/Search.hs new file mode 100644 --- /dev/null +++ b/src/Search.hs @@ -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 diff --git a/src/Template.hs b/src/Template.hs new file mode 100644 --- /dev/null +++ b/src/Template.hs @@ -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)