FollowboxOrigin.hs

{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE BlockArguments, LambdaCase, TupleSections, OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Control.Moffy.Samples.FollowboxOrigin (
	-- * followbox
	followbox ) where

import Prelude hiding (break, repeat, scanl)

import Control.Arrow ((>>>))
import Control.Monad (void, forever, (<=<))
import Control.Moffy (React, adjust, emit, waitFor, break, indexBy, find, repeat, scanl)
import Control.Moffy.Event.Lock (newLockId, withLock)
import Control.Moffy.Samples.Event.Random (getRandomR)
import Control.Moffy.Samples.Event.Delete (deleteEvent)
import Control.Moffy.Samples.Viewable.Basic (Position, Color(..), LineWidth)
import Control.Moffy.Samples.Followbox.Event (
	SigF, ReactF,
	httpGet, getTimeZone, beginSleep, checkBeginSleep, endSleep,
	Error(..), raiseError, checkTerminate )
import Control.Moffy.Samples.Followbox.Clickable (
	view, click, clickableText, withTextExtents, FontName, FontSize )
import Control.Moffy.Samples.Followbox.ViewType (
	View(..), white, Png(..), VText(..), Line(..), Image(..) )
import Control.Moffy.Samples.Followbox.TypeSynonym (ErrorMessage)
import Data.Type.Set
import Data.Type.Flip ((<$%>), (<*%>))
import Data.OneOfThem
import Data.HashMap.Strict qualified as HM
import Data.Hashable
import Data.Bool
import Data.ByteString.Char8 qualified as BSC
import Data.ByteString.Lazy qualified as LBS
import Data.Text qualified as T
import Data.Time (utcToLocalTime, UTCTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Data.Aeson (Object, Value(..), eitherDecode)
import Data.Aeson.KeyMap (toHashMap)
import Text.Read (readMaybe)
import Codec.Picture qualified as P

import Control.Moffy.Samples.Event.Mouse qualified as Mouse
import Control.Moffy.Samples.Event.Area

---------------------------------------------------------------------------

-- * PARAMETER LIST
-- 	+ MAX NUMBER OF GITHUB USER
-- 	+ BACKGROUND
-- 	+ FONT
-- 	+ AVATAR, NAME AND CROSS
-- 	+ COLORS
-- * SIG AND REACT
--	+ FOLLOWBOX
--	+ USER VIEW
--	+ GET USERS
--	+ GET OBJECT
-- * MOUSE EVENTS
-- * VIEWS
-- * ERRORS

---------------------------------------------------------------------------
-- PARAMETER LIST
---------------------------------------------------------------------------

-- MAX NUMBER OF GITHUB USER

userPageMax :: Int
userPageMax = 2 ^ (27 :: Int)

-- BACKGROUND

titlePos, refreshPos, resetTimePos :: Position
titlePos = (50, 44); refreshPos = (600, 65)
resetTimePos = (100, 470)

-- FONT

defaultFont :: FontName
defaultFont = "sans"

middleSize, largeSize :: FontSize
middleSize = 30; largeSize = 40

-- AVATAR, NAME AND CROSS

avatarSizeX, avatarSizeY :: Double
(avatarSizeX, avatarSizeY) = (80, 80)

avatarPos, namePos :: Int -> Position
avatarPos n = (100, 120 + 120 * fromIntegral n)
namePos n = (210, 150 + 120 * fromIntegral n)

crossSize :: Double
crossSize = largeSize / 2

crossPos :: Int -> Position
crossPos n = (500, 162 + 120 * fromIntegral n)

crossMergin :: Double
crossMergin = 5

-- COLORS

barColor :: Color
barColor = Color 0x32 0xcd 0x32

nameColor :: Color
nameColor = Color 0x00 0xcd 0x00

---------------------------------------------------------------------------
-- SIG AND REACT
---------------------------------------------------------------------------

-- FOLLOWBOX

followbox :: SigF s View ()
followbox = void $ fieldWithResetTime `break` deleteEvent `break` checkTerminate

fieldWithResetTime :: SigF s View ()
fieldWithResetTime = (<>) <$%> field <*%> resetTime

field :: SigF s View ()
field = do
	rfs <- waitFor $ link refreshPos "Refresh"
	lck <- waitFor $ adjust newLockId
	let	frame = title <> view rfs
		refresh = forever do
			emit Nothing
			us <- Just . Left <$%> users
			emit . Just $ Right us
			waitFor . adjust $ click rfs
		close i = forever do
			emit =<< waitFor (withLock lck
				(adjust $ getRandomR (0, 29) :: ReactF s Int))
			waitFor . clickArea $ crossArea i
	emit frame
	(frame <>) <$%> ((\a b c -> a <> b <> c)
		<$%> (chooseUser 0 <$%> refresh <*%> close 0)
		<*%> (chooseUser 1 <$%> refresh <*%> close 1)
		<*%> (chooseUser 2 <$%> refresh <*%> close 2))
	where
	title = text white largeSize titlePos "Who to follow"
	link p t = clickableText p
		<$> adjust (withTextExtents defaultFont middleSize t)

chooseUser :: Int -> Maybe (Either Int [(Png, T.Text)]) -> Int -> View
chooseUser _ (Just (Left i)) _ = bar $ fromIntegral i
chooseUser n (Just (Right us)) i = userView n (us !! (i `mod` length us))
chooseUser _ Nothing _ = View []

resetTime :: SigF s View ()
resetTime = forever do
	emit $ View []
	emit =<< waitFor do
		(t, tz) <- (,) <$> adjust checkBeginSleep <*> adjust getTimeZone
		pure . text white middleSize resetTimePos . T.pack
			$ "Wait until " <> show (utcToLocalTime tz t)
	waitFor $ adjust endSleep

-- USER VIEW

userView :: Int -> (Png, T.Text) -> View
userView n (avt, nm) = image (avatarPos n) avt <> name n nm <> cross n

name :: Int -> T.Text -> View
name n nm = text nameColor largeSize (namePos n) nm

cross :: Int -> View
cross (crossPos -> (l, t)) = line white 4 lt rb <> line white 4 lb rt
	where
	(lt, lb, rt, rb) = ((l, t), (l, b), (r, t), (r, b))
	(r, b) = (l + crossSize, t + crossSize)

crossArea :: Int -> (Position, Position)
crossArea (crossPos -> (l, t)) = ((l', t'), (r', b'))
	where
	(r, b) = (l + crossSize, t + crossSize)
	(l', t') = (l - crossMergin, t - crossMergin)
	(r', b') = (r + crossMergin, b + crossMergin)

-- GET USERS

users :: SigF s Int [(Png, T.Text)]
users = waitFor (mapM ex2 <$> getObjs') >>= err \(unzip -> (avs, nms)) ->
	sequence <$> ssum (avatar `mapM` avs) >>= err (pure . flip zip nms)
	where
	ex2 (toHashMap -> o) = (,)
		<$> extract "avatar_url" o noAvatarAddress
		<*> extract "login" o noLoginName
	ssum = scanl (+) 0
	err = either \e -> waitFor (adjust (uncurry raiseError e)) >> users

extract :: Hashable k => k -> HM.HashMap k Value -> e -> Either e T.Text
extract k o e = case HM.lookup k o of Just (String v) -> Right v; _ -> Left e

avatar :: T.Text -> SigF s Int (Either (Error, ErrorMessage) Png)
avatar url = emit 1 >> waitFor (png . snd <$> adjust (httpGet url))

png :: LBS.ByteString -> Either (Error, String) Png
png = LBS.toStrict >>> convert >>>
	either (Left . (NoAvatar ,)) (Right . Png avatarSizeX avatarSizeY)
	where convert img =
		LBS.toStrict . P.encodePng . P.convertRGB8 <$> P.decodeImage img

bar :: Double -> View
bar p = line barColor 50 (80, 300) (80 + p * 25, 300)

-- GET OBJECT

getObjs' :: ReactF s [Object]
getObjs' = getObjs >>= \case
	Left em -> adjust (raiseError NotJson em) >> getObjs'
	Right [] -> adjust (raiseError EmptyJson "Empty JSON") >> getObjs'
	Right os -> pure os

getObjs :: ReactF s (Either String [Object])
getObjs = do
	n <- adjust $ getRandomR (0, userPageMax)
	(hdr, bdy) <- adjust . httpGet $ api n
	case (rmng hdr, rst hdr) of
		(Just rmn, _) | rmn > (0 :: Int) -> pure $ eitherDecode bdy
		(Just _, Just t) -> sleep t >> getObjs
		(Just _, Nothing) -> err noRateLimitReset >> getObjs
		(Nothing, _) -> err noRateLimitRemaining >> getObjs
	where
	api = ("https://api.github.com/users?since=" <>) . T.pack . show @Int
	rmng = (read . BSC.unpack <$>) . lookup "X-RateLimit-Remaining"
	rst = ut <=< lookup "X-RateLimit-Reset"
	ut = (posixSecondsToUTCTime . fromInteger <$>) . readMaybe . BSC.unpack
	err :: (Error, String) -> ReactF s ()
	err = adjust . uncurry raiseError

sleep :: UTCTime -> ReactF s ()
sleep t = adjust (beginSleep t) >> adjust endSleep

---------------------------------------------------------------------------
-- MOUSE EVENTS
---------------------------------------------------------------------------

clickArea :: (Point, Point) -> ReactF s ()
clickArea ((l, u), (r, d)) = void . adjust
	. find inside $ fst <$%> repeat Mouse.move `indexBy` repeat leftClick
	where inside (x, y) = l <= x && x <= r && u <= y && y <= d

leftClick :: React s (Singleton Mouse.Down) ()
leftClick = clickOn Mouse.ButtonPrimary

clickOn :: Mouse.Button -> React s (Singleton Mouse.Down) ()
clickOn b0 = bool (clickOn b0) (pure ()) . (== b0) =<< Mouse.down

---------------------------------------------------------------------------
-- VIEWS
---------------------------------------------------------------------------

text :: Color -> FontSize -> Position -> T.Text -> View
text c fs p = View . (: []) . expand . Singleton . Text' c defaultFont fs p

line :: Color -> LineWidth -> Position -> Position -> View
line c w p q = View . (: []) . expand . Singleton $ Line' c w p q

image :: Position -> Png -> View
image p = View . (: []) . expand . Singleton . Image' p

---------------------------------------------------------------------------
-- ERRORS
---------------------------------------------------------------------------

noRateLimitRemaining,
	noRateLimitReset, noAvatarAddress, noLoginName :: (Error, String)
noRateLimitRemaining = (NoRateLimitRemaining, "No X-RateLimit-Remaining header")
noRateLimitReset = (NoRateLimitReset, "No X-RateLimit-Reset header")
noAvatarAddress = (NoAvatarAddress, "No Avatar Address")
noLoginName = (NoLoginName, "No Login Name")