Utils.hs

{-# LANGUAGE RankNTypes #-}

-- | Internal module
module Web.Exhentai.Utils where

import Conduit
import Control.Effect
import Control.Effect.Bracket
import Control.Effect.Error
import Control.Effect.Exh
import Control.Monad.Trans.Cont
import Data.Aeson
import Data.ByteString (ByteString)
import Data.Text (Text, pack, unpack)
import Data.Time
import Network.HTTP.Client hiding (Cookie)
import Optics.Core
import Text.HTML.DOM
import Text.Read (readMaybe)
import Text.XML hiding (sinkDoc)
import Text.XML.Optics
import Prelude hiding ((!!))

body :: Traversal' Document Element
body = (root % named "html") .// named "body"
{-# INLINE body #-}

div :: AffineTraversal' Element Element
div = named "div"
{-# INLINE div #-}

h1 :: AffineTraversal' Element Element
h1 = named "h1"
{-# INLINE h1 #-}

a :: AffineTraversal' Element Element
a = named "a"
{-# INLINE a #-}

table :: AffineTraversal' Element Element
table = named "table"
{-# INLINE table #-}

tr :: AffineTraversal' Element Element
tr = named "tr"
{-# INLINE tr #-}

td :: AffineTraversal' Element Element
td = named "td"
{-# INLINE td #-}

img :: AffineTraversal' Element Element
img = named "img"
{-# INLINE img #-}

cl :: Text -> AffineTraversal' Element Element
cl = attributeIs "class"
{-# INLINE cl #-}

id :: Text -> AffineTraversal' Element Element
id = attributeIs "id"
{-# INLINE id #-}

viaShowRead :: (Show a, Read a) => Prism' Text a
viaShowRead = prism' (pack . show) (readMaybe . unpack)
{-# INLINE viaShowRead #-}

scripts :: AffineTraversal' Element Element
scripts = named "script" % attributeIs "type" "text/javascript"
{-# INLINE scripts #-}

infixl 8 ^?:

(^?:) :: (Is (Join A_Traversal l) A_Fold, Is l (Join A_Traversal l), Is A_Traversal (Join A_Traversal l)) => Document -> Optic l is Element Element a a -> Maybe a
doc ^?: fld = doc ^? pre (body .// fld)
{-# INLINE (^?:) #-}

infixl 8 ^..:

(^..:) :: (Is (Join A_Traversal l) A_Fold, Is l (Join A_Traversal l), Is A_Traversal (Join A_Traversal l)) => Document -> Optic l is Element Element a a -> [a]
doc ^..: fld = doc ^.. body .// fld
{-# INLINE (^..:) #-}

sinkAeson :: (FromJSON a, Monad m) => ConduitT ByteString o m (Either String a)
sinkAeson = eitherDecode <$> sinkLazy
{-# INLINE sinkAeson #-}

jsonRequest :: (FromJSON a, Effs '[Http, Error HttpException, ConduitIO, Cookie, Bracket] m) => Request -> m (Either String a)
jsonRequest req = evalContT $ do
  resp <- withSource req
  lift $ runConduitIO $ responseBody resp .| sinkAeson
{-# INLINEABLE jsonRequest #-}

htmlRequest :: Effs '[Http, Error HttpException, ConduitIO, Cookie, Bracket] m => Request -> m Document
htmlRequest req = evalContT $ do
  resp <- withSource req
  lift $ runConduitIO $ responseBody resp .| sinkDoc
{-# INLINEABLE htmlRequest #-}

htmlRequest' :: Effs '[Http, Error HttpException, ConduitIO, Cookie, Bracket] m => Text -> m Document
htmlRequest' url = do
  req <- formRequest $ unpack url
  htmlRequest req
{-# INLINEABLE htmlRequest' #-}

parseUploadTime :: Text -> Maybe UTCTime
parseUploadTime s = parseTimeM True defaultTimeLocale "%F %R" $ unpack s
{-# INLINE parseUploadTime #-}

annotate :: ann -> Maybe a -> Either ann a
annotate _ (Just a') = Right a'
annotate ann Nothing = Left ann
{-# INLINE annotate #-}

(!!) :: [a] -> Int -> Maybe a
l !! i
  | i == 0,
    (x : _) <- l =
    Just x
  | i > 0,
    (_ : xs) <- l =
    xs !! (i - 1)
  | otherwise = Nothing
{-# INLINE (!!) #-}