Phsu-0.1.0.3: src/Diffs.hs

{-# 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