module Handler.Archive where

import Import
import Data.Function ((&))
import Data.Char (ord)
import qualified Data.Attoparsec.ByteString.Char8 as AP8
import qualified Data.Attoparsec.ByteString as AP
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as BS8
import qualified Network.HTTP.Client as NH
import qualified Network.HTTP.Client.TLS as NH
import qualified Network.HTTP.Types.Status as NH
import qualified Web.FormUrlEncoded as WH
import HTMLEntities.Decoder (htmlEncodedText)
import Data.Text.Lazy.Builder (toLazyText)
import Network.Wai (requestHeaderHost)
import qualified Network.Connection as NC

shouldArchiveBookmark :: User -> Key Bookmark -> Handler Bool
shouldArchiveBookmark :: User -> Key Bookmark -> Handler Bool
shouldArchiveBookmark User
user Key Bookmark
kbid =
  forall site a.
YesodPersist site =>
YesodDB site a -> HandlerFor site a
runDB (forall backend record (m :: * -> *).
(PersistStoreRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
get Key Bookmark
kbid) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Maybe Bookmark
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

  Just Bookmark
bm -> do
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
      forall a. Maybe a -> Bool
isNothing (Bookmark -> Maybe Text
bookmarkArchiveHref Bookmark
bm) Bool -> Bool -> Bool
&&
      Bookmark -> Bool
bookmarkShared Bookmark
bm
      Bool -> Bool -> Bool
&& Bool -> Bool
not (Bookmark -> Bool
_isArchiveBlacklisted Bookmark
bm)
      Bool -> Bool -> Bool
&& User -> Bool
userArchiveDefault User
user

getArchiveManager :: Handler Manager
getArchiveManager :: Handler Manager
getArchiveManager = do
  AppSettings
appSettings <- App -> AppSettings
appSettings forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
  let mSocks :: Maybe ProxySettings
mSocks =
        String -> PortNumber -> ProxySettings
NC.SockSettingsSimple forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall mono. MonoFoldable mono => mono -> [Element mono]
unpack (AppSettings -> Maybe Text
appArchiveSocksProxyHost AppSettings
appSettings) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Enum a => Int -> a
toEnum (AppSettings -> Maybe Int
appArchiveSocksProxyPort AppSettings
appSettings)
  forall (m :: * -> *). MonadIO m => ManagerSettings -> m Manager
NH.newTlsManagerWith (TLSSettings -> Maybe ProxySettings -> ManagerSettings
NH.mkManagerSettings forall a. Default a => a
def Maybe ProxySettings
mSocks)


archiveBookmarkUrl :: Key Bookmark -> String -> Handler ()
archiveBookmarkUrl :: Key Bookmark -> String -> Handler ()
archiveBookmarkUrl Key Bookmark
kbid String
url =
  (Handler (Either String (String, String))
_fetchArchiveSubmitInfo forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left String
e -> do
      $(logError) (forall seq. IsSequence seq => [Element seq] -> seq
pack String
e)
    Right (String, String)
submitInfo ->  do
        Key User
userId <- forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
m (AuthId (HandlerSite m))
requireAuthId
        Request
req <- (String, String) -> String -> Handler Request
_buildArchiveSubmitRequest (String, String)
submitInfo String
url
        Manager
manager <- Handler Manager
getArchiveManager
        Response ByteString
res <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
NH.httpLbs Request
req Manager
manager
        let status :: Status
status = forall body. Response body -> Status
NH.responseStatus Response ByteString
res
        let updateArchiveUrl :: Text -> Handler ()
updateArchiveUrl Text
url' = forall site a.
YesodPersist site =>
YesodDB site a -> HandlerFor site a
runDB forall a b. (a -> b) -> a -> b
$ Key User -> Key Bookmark -> Maybe Text -> DB ()
updateBookmarkArchiveUrl Key User
userId Key Bookmark
kbid forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Text
url'
            headers :: ResponseHeaders
headers = forall body. Response body -> ResponseHeaders
NH.responseHeaders Response ByteString
res
        case Status
status of
          Status
s | Status
s forall a. Eq a => a -> a -> Bool
== Status
NH.status200 ->
            forall mono (f :: * -> *) b.
(MonoFoldable mono, Applicative f) =>
mono -> (Element mono -> f b) -> f ()
for_ (forall map.
IsMap map =>
ContainerKey map -> map -> Maybe (MapValue map)
lookup HeaderName
"Refresh" ResponseHeaders
headers forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe Text
_parseRefreshHeaderUrl) Text -> Handler ()
updateArchiveUrl
          Status
s | Status
s forall a. Eq a => a -> a -> Bool
== Status
NH.status302 Bool -> Bool -> Bool
|| Status
s forall a. Eq a => a -> a -> Bool
== Status
NH.status307 ->
            forall mono (f :: * -> *) b.
(MonoFoldable mono, Applicative f) =>
mono -> (Element mono -> f b) -> f ()
for_ (forall map.
IsMap map =>
ContainerKey map -> map -> Maybe (MapValue map)
lookup HeaderName
"Location" ResponseHeaders
headers) (Text -> Handler ()
updateArchiveUrl forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall textual binary. Utf8 textual binary => binary -> textual
decodeUtf8)
          Status
_ -> $(logError) (forall seq. IsSequence seq => [Element seq] -> seq
pack (forall a. Show a => a -> String
show Response ByteString
res)))
  forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\(SomeException
e::SomeException) -> ($(logError) forall a b. (a -> b) -> a -> b
$ (forall seq. IsSequence seq => [Element seq] -> seq
packforall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.forall a. Show a => a -> String
show) SomeException
e) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SomeException
e)

_isArchiveBlacklisted :: Bookmark -> Bool
_isArchiveBlacklisted :: Bookmark -> Bool
_isArchiveBlacklisted Bookmark {Bool
Maybe Text
UTCTime
Text
Key User
BmSlug
bookmarkSelected :: Bookmark -> Bool
bookmarkToRead :: Bookmark -> Bool
bookmarkTime :: Bookmark -> UTCTime
bookmarkExtended :: Bookmark -> Text
bookmarkDescription :: Bookmark -> Text
bookmarkHref :: Bookmark -> Text
bookmarkSlug :: Bookmark -> BmSlug
bookmarkUserId :: Bookmark -> Key User
bookmarkArchiveHref :: Maybe Text
bookmarkSelected :: Bool
bookmarkToRead :: Bool
bookmarkShared :: Bool
bookmarkTime :: UTCTime
bookmarkExtended :: Text
bookmarkDescription :: Text
bookmarkHref :: Text
bookmarkSlug :: BmSlug
bookmarkUserId :: Key User
bookmarkShared :: Bookmark -> Bool
bookmarkArchiveHref :: Bookmark -> Maybe Text
..} =
  [ Text
"hulu"
  , Text
"livestream"
  , Text
"netflix"
  , Text
"skillsmatter"
  , Text
"twitch.tv"
  , Text
"vimeo"
  , Text
"youtu.be"
  , Text
"youtube"
  , Text
"archive."
  ] forall a b. a -> (a -> b) -> b
&
  forall mono.
MonoFoldable mono =>
(Element mono -> Bool) -> mono -> Bool
any (forall seq.
(IsSequence seq, Eq (Element seq)) =>
seq -> seq -> Bool
`isInfixOf` Text
bookmarkHref)

_parseRefreshHeaderUrl :: ByteString -> Maybe Text
_parseRefreshHeaderUrl :: ByteString -> Maybe Text
_parseRefreshHeaderUrl ByteString
h = do
  let u :: ByteString
u = Int -> ByteString -> ByteString
BS8.drop Int
1 forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
BS8.dropWhile (forall a. Eq a => a -> a -> Bool
/= Char
'=') ByteString
h
  if Bool -> Bool
not (forall mono. MonoFoldable mono => mono -> Bool
null ByteString
u)
    then forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall textual binary. Utf8 textual binary => binary -> textual
decodeUtf8 ByteString
u
    else forall a. Maybe a
Nothing

_fetchArchiveSubmitInfo :: Handler (Either String (String , String))
_fetchArchiveSubmitInfo :: Handler (Either String (String, String))
_fetchArchiveSubmitInfo = do
  Request
req <- String -> Handler Request
buildRequest String
"https://archive.li/"
  Manager
manager <- Handler Manager
getArchiveManager
  Response ByteString
res <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
NH.httpLbs Request
req Manager
manager
  let body :: ByteString
body = ByteString -> ByteString
LBS.toStrict (forall body. Response body -> body
responseBody Response ByteString
res)
      action :: Either String String
action = Parser ByteString
-> Parser Char -> ByteString -> Either String String
_parseSubstring (ByteString -> Parser ByteString
AP8.string ByteString
"action=\"") (Char -> Parser Char
AP8.notChar Char
'"') ByteString
body
      submitId :: Either String String
submitId = Parser ByteString
-> Parser Char -> ByteString -> Either String String
_parseSubstring (ByteString -> Parser ByteString
AP8.string ByteString
"submitid\" value=\"") (Char -> Parser Char
AP8.notChar Char
'"') ByteString
body
  if Status -> Int
statusCode (forall body. Response body -> Status
responseStatus Response ByteString
res) forall a. Eq a => a -> a -> Bool
== Int
200
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either String String
action forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Either String String
submitId
    else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Invalid statusCode: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall body. Response body -> Status
responseStatus Response ByteString
res)


_parseSubstring :: AP8.Parser ByteString -> AP8.Parser Char -> BS.ByteString -> Either String String
_parseSubstring :: Parser ByteString
-> Parser Char -> ByteString -> Either String String
_parseSubstring Parser ByteString
start Parser Char
inner = forall a. Parser a -> ByteString -> Either String a
AP8.parseOnly (forall {a}. Parser ByteString a -> Parser ByteString ()
skipAnyTill Parser ByteString
start forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Alternative f => f a -> f [a]
AP8.many1 Parser Char
inner)
  where
    skipAnyTill :: Parser ByteString a -> Parser ByteString ()
skipAnyTill Parser ByteString a
end = Parser ByteString ()
go where go :: Parser ByteString ()
go = Parser ByteString a
end forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> () forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Char
AP8.anyChar forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString ()
go


fetchPageTitle :: String -> Handler (Either String Text)
fetchPageTitle :: String -> Handler (Either String Text)
fetchPageTitle String
url =
  do
     Request
req <- String -> Handler Request
buildRequest String
url
     Response ByteString
res <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
NH.httpLbs Request
req forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Manager
NH.getGlobalManager
     let body :: ByteString
body = ByteString -> ByteString
LBS.toStrict (forall body. Response body -> body
responseBody Response ByteString
res)
     forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Text
decodeHtmlBs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either String ByteString
parseTitle ByteString
body)
     forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\(SomeException
e :: SomeException) -> do
                $(logError) forall a b. (a -> b) -> a -> b
$ (forall seq. IsSequence seq => [Element seq] -> seq
pack forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Show a => a -> String
show) SomeException
e
                forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left (forall a. Show a => a -> String
show SomeException
e)))
  where
    parseTitle :: ByteString -> Either String ByteString
parseTitle ByteString
bs =
      forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Parser a -> ByteString -> Either String a
AP.parseOnly ByteString
bs do
        ()
_ <- forall {a}. Parser ByteString a -> Parser ByteString ()
skipAnyTill (ByteString -> Parser ByteString
AP.string ByteString
"<title")
        ()
_ <- forall {a}. Parser ByteString a -> Parser ByteString ()
skipAnyTill (ByteString -> Parser ByteString
AP.string ByteString
">")
        let lt :: Word8
lt = forall a. Enum a => Int -> a
toEnum (Char -> Int
ord Char
'<')
        (Word8 -> Bool) -> Parser ByteString
AP.takeTill (forall a. Eq a => a -> a -> Bool
== Word8
lt)
    decodeHtmlBs :: ByteString -> Text
decodeHtmlBs = forall lazy strict. LazySequence lazy strict => lazy -> strict
toStrict forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Builder -> Text
toLazyText forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> Builder
htmlEncodedText forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall textual binary. Utf8 textual binary => binary -> textual
decodeUtf8
    skipAnyTill :: Parser ByteString a -> Parser ByteString ()
skipAnyTill Parser ByteString a
end = Parser ByteString ()
go where go :: Parser ByteString ()
go = Parser ByteString a
end forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> () forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Word8
AP.anyWord8 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString ()
go

_buildArchiveSubmitRequest :: (String, String) -> String -> Handler NH.Request
_buildArchiveSubmitRequest :: (String, String) -> String -> Handler Request
_buildArchiveSubmitRequest (String
action, String
submitId) String
href = do
  Request
req <- String -> Handler Request
buildRequest (String
"POST " forall a. Semigroup a => a -> a -> a
<> String
action)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Request
req
    { requestHeaders :: ResponseHeaders
NH.requestHeaders = (HeaderName
"Content-Type", ByteString
"application/x-www-form-urlencoded") forall a. a -> [a] -> [a]
: Request -> ResponseHeaders
NH.requestHeaders Request
req
    , requestBody :: RequestBody
NH.requestBody =
        ByteString -> RequestBody
NH.RequestBodyLBS forall a b. (a -> b) -> a -> b
$
        forall a. ToForm a => a -> ByteString
WH.urlEncodeAsForm
            ([(String
"submitid", String
submitId), (String
"url", String
href)] :: [(String, String)])
    , redirectCount :: Int
NH.redirectCount = Int
0
    }

buildRequest :: String -> Handler Request
buildRequest :: String -> Handler Request
buildRequest String
url = do
  ByteString
ua <- Handler ByteString
_archiveUserAgent
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> Request
NH.parseRequest_ String
url forall a b. a -> (a -> b) -> b
& \Request
r ->
    Request
r { requestHeaders :: ResponseHeaders
NH.requestHeaders =
          [ (HeaderName
"Cache-Control", ByteString
"max-age=0")
          , (HeaderName
"User-Agent", ByteString
ua)
          ]
      }

_archiveUserAgent :: Handler ByteString
_archiveUserAgent :: Handler ByteString
_archiveUserAgent = do
  Maybe ByteString
mHost <- Request -> Maybe ByteString
requestHeaderHost forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. YesodRequest -> Request
reqWaiRequest forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ByteString
"espial-" forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" ((Char -> Bool) -> ByteString -> ByteString
BS8.takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
':')) Maybe ByteString
mHost