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 =
  YesodDB App (Maybe Bookmark) -> HandlerFor App (Maybe Bookmark)
forall a. YesodDB App a -> HandlerFor App a
forall site a.
YesodPersist site =>
YesodDB site a -> HandlerFor site a
runDB (Key Bookmark
-> ReaderT SqlBackend (HandlerFor App) (Maybe Bookmark)
forall backend record (m :: * -> *).
(PersistStoreRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Key record -> ReaderT SqlBackend m (Maybe record)
get Key Bookmark
kbid) HandlerFor App (Maybe Bookmark)
-> (Maybe Bookmark -> Handler Bool) -> Handler Bool
forall a b.
HandlerFor App a -> (a -> HandlerFor App b) -> HandlerFor App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Maybe Bookmark
Nothing -> Bool -> Handler Bool
forall a. a -> HandlerFor App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

  Just Bookmark
bm -> do
    Bool -> Handler Bool
forall a. a -> HandlerFor App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Handler Bool) -> Bool -> Handler Bool
forall a b. (a -> b) -> a -> b
$
      Maybe Text -> Bool
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 (App -> AppSettings)
-> HandlerFor App App -> HandlerFor App AppSettings
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HandlerFor App (HandlerSite (HandlerFor App))
HandlerFor App App
forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
  let mSocks :: Maybe ProxySettings
mSocks =
        String -> PortNumber -> ProxySettings
NC.SockSettingsSimple (String -> PortNumber -> ProxySettings)
-> Maybe String -> Maybe (PortNumber -> ProxySettings)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        (Text -> String) -> Maybe Text -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> String
Text -> [Element Text]
forall mono. MonoFoldable mono => mono -> [Element mono]
unpack (AppSettings -> Maybe Text
appArchiveSocksProxyHost AppSettings
appSettings) Maybe (PortNumber -> ProxySettings)
-> Maybe PortNumber -> Maybe ProxySettings
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
        (Int -> PortNumber) -> Maybe Int -> Maybe PortNumber
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> PortNumber
forall a. Enum a => Int -> a
toEnum (AppSettings -> Maybe Int
appArchiveSocksProxyPort AppSettings
appSettings)
  ManagerSettings -> Handler Manager
forall (m :: * -> *). MonadIO m => ManagerSettings -> m Manager
NH.newTlsManagerWith (TLSSettings -> Maybe ProxySettings -> ManagerSettings
NH.mkManagerSettings TLSSettings
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 Handler (Either String (String, String))
-> (Either String (String, String) -> Handler ()) -> Handler ()
forall a b.
HandlerFor App a -> (a -> HandlerFor App b) -> HandlerFor App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left String
e -> do
      $(logError) ([Element Text] -> Text
forall seq. IsSequence seq => [Element seq] -> seq
pack String
[Element Text]
e)
    Right (String, String)
submitInfo ->  do
        Key User
userId <- HandlerFor App (Key User)
HandlerFor App (AuthId (HandlerSite (HandlerFor App)))
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 <- IO (Response ByteString) -> HandlerFor App (Response ByteString)
forall a. IO a -> HandlerFor App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Response ByteString) -> HandlerFor App (Response ByteString))
-> IO (Response ByteString) -> HandlerFor App (Response ByteString)
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
NH.httpLbs Request
req Manager
manager
        let status :: Status
status = Response ByteString -> Status
forall body. Response body -> Status
NH.responseStatus Response ByteString
res
        let updateArchiveUrl :: Text -> Handler ()
updateArchiveUrl Text
url' = YesodDB App () -> Handler ()
forall a. YesodDB App a -> HandlerFor App a
forall site a.
YesodPersist site =>
YesodDB site a -> HandlerFor site a
runDB (YesodDB App () -> Handler ()) -> YesodDB App () -> Handler ()
forall a b. (a -> b) -> a -> b
$ Key User -> Key Bookmark -> Maybe Text -> DB ()
updateBookmarkArchiveUrl Key User
userId Key Bookmark
kbid (Maybe Text -> DB ()) -> Maybe Text -> DB ()
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
url'
            headers :: ResponseHeaders
headers = Response ByteString -> ResponseHeaders
forall body. Response body -> ResponseHeaders
NH.responseHeaders Response ByteString
res
        case Status
status of
          Status
s | Status
s Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
NH.status200 ->
            Maybe Text -> (Element (Maybe Text) -> Handler ()) -> Handler ()
forall mono (f :: * -> *) b.
(MonoFoldable mono, Applicative f) =>
mono -> (Element mono -> f b) -> f ()
for_ (ContainerKey ResponseHeaders
-> ResponseHeaders -> Maybe (MapValue ResponseHeaders)
forall map.
IsMap map =>
ContainerKey map -> map -> Maybe (MapValue map)
lookup HeaderName
ContainerKey ResponseHeaders
"Refresh" ResponseHeaders
headers Maybe ByteString -> (ByteString -> Maybe Text) -> Maybe Text
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe Text
_parseRefreshHeaderUrl) Text -> Handler ()
Element (Maybe Text) -> Handler ()
updateArchiveUrl
          Status
s | Status
s Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
NH.status302 Bool -> Bool -> Bool
|| Status
s Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
NH.status307 ->
            Maybe ByteString
-> (Element (Maybe ByteString) -> Handler ()) -> Handler ()
forall mono (f :: * -> *) b.
(MonoFoldable mono, Applicative f) =>
mono -> (Element mono -> f b) -> f ()
for_ (ContainerKey ResponseHeaders
-> ResponseHeaders -> Maybe (MapValue ResponseHeaders)
forall map.
IsMap map =>
ContainerKey map -> map -> Maybe (MapValue map)
lookup HeaderName
ContainerKey ResponseHeaders
"Location" ResponseHeaders
headers) (Text -> Handler ()
updateArchiveUrl (Text -> Handler ())
-> (ByteString -> Text) -> ByteString -> Handler ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> Text
forall textual binary. Utf8 textual binary => binary -> textual
decodeUtf8)
          Status
_ -> $(logError) ([Element Text] -> Text
forall seq. IsSequence seq => [Element seq] -> seq
pack (Response ByteString -> String
forall a. Show a => a -> String
show Response ByteString
res)))
  Handler () -> (SomeException -> Handler ()) -> Handler ()
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\(SomeException
e::SomeException) -> ($(logError) (Text -> Handler ()) -> Text -> Handler ()
forall a b. (a -> b) -> a -> b
$ (String -> Text
[Element Text] -> Text
forall seq. IsSequence seq => [Element seq] -> seq
pack(String -> Text)
-> (SomeException -> String) -> SomeException -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.SomeException -> String
forall a. Show a => a -> String
show) SomeException
e) Handler () -> Handler () -> Handler ()
forall a b.
HandlerFor App a -> HandlerFor App b -> HandlerFor App b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SomeException -> Handler ()
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
Text
UTCTime
Key User
BmSlug
bookmarkArchiveHref :: Bookmark -> Maybe Text
bookmarkShared :: Bookmark -> Bool
bookmarkUserId :: Key User
bookmarkSlug :: BmSlug
bookmarkHref :: Text
bookmarkDescription :: Text
bookmarkExtended :: Text
bookmarkTime :: UTCTime
bookmarkShared :: Bool
bookmarkToRead :: Bool
bookmarkSelected :: Bool
bookmarkArchiveHref :: Maybe Text
bookmarkUserId :: Bookmark -> Key User
bookmarkSlug :: Bookmark -> BmSlug
bookmarkHref :: Bookmark -> Text
bookmarkDescription :: Bookmark -> Text
bookmarkExtended :: Bookmark -> Text
bookmarkTime :: Bookmark -> UTCTime
bookmarkToRead :: Bookmark -> Bool
bookmarkSelected :: Bookmark -> Bool
..} =
  [ Text
"hulu"
  , Text
"livestream"
  , Text
"netflix"
  , Text
"skillsmatter"
  , Text
"twitch.tv"
  , Text
"vimeo"
  , Text
"youtu.be"
  , Text
"youtube"
  , Text
"archive."
  ] [Text] -> ([Text] -> Bool) -> Bool
forall a b. a -> (a -> b) -> b
&
  (Element [Text] -> Bool) -> [Text] -> Bool
forall mono.
MonoFoldable mono =>
(Element mono -> Bool) -> mono -> Bool
any (Text -> Text -> Bool
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 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
BS8.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'=') ByteString
h
  if Bool -> Bool
not (ByteString -> Bool
forall mono. MonoFoldable mono => mono -> Bool
null ByteString
u)
    then Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
forall textual binary. Utf8 textual binary => binary -> textual
decodeUtf8 ByteString
u
    else Maybe Text
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 <- IO (Response ByteString) -> HandlerFor App (Response ByteString)
forall a. IO a -> HandlerFor App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Response ByteString) -> HandlerFor App (Response ByteString))
-> IO (Response ByteString) -> HandlerFor App (Response ByteString)
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 (Response ByteString -> ByteString
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 (Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
res) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
200
    then Either String (String, String)
-> Handler (Either String (String, String))
forall a. a -> HandlerFor App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String (String, String)
 -> Handler (Either String (String, String)))
-> Either String (String, String)
-> Handler (Either String (String, String))
forall a b. (a -> b) -> a -> b
$ (,) (String -> String -> (String, String))
-> Either String String
-> Either String (String -> (String, String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either String String
action Either String (String -> (String, String))
-> Either String String -> Either String (String, String)
forall a b.
Either String (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Either String String
submitId
    else Either String (String, String)
-> Handler (Either String (String, String))
forall a. a -> HandlerFor App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String (String, String)
 -> Handler (Either String (String, String)))
-> Either String (String, String)
-> Handler (Either String (String, String))
forall a b. (a -> b) -> a -> b
$ String -> Either String (String, String)
forall a b. a -> Either a b
Left (String -> Either String (String, String))
-> String -> Either String (String, String)
forall a b. (a -> b) -> a -> b
$ String
"Invalid statusCode: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Status -> String
forall a. Show a => a -> String
show (Response ByteString -> Status
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 = Parser String -> ByteString -> Either String String
forall a. Parser a -> ByteString -> Either String a
AP8.parseOnly (Parser ByteString -> Parser ByteString ()
forall {a}. Parser ByteString a -> Parser ByteString ()
skipAnyTill Parser ByteString
start Parser ByteString () -> Parser String -> Parser String
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Char -> Parser String
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 Parser ByteString a -> () -> Parser ByteString ()
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> () Parser ByteString ()
-> Parser ByteString () -> Parser ByteString ()
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Char
AP8.anyChar Parser Char -> Parser ByteString () -> Parser ByteString ()
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
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 <- IO (Response ByteString) -> HandlerFor App (Response ByteString)
forall a. IO a -> HandlerFor App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Response ByteString) -> HandlerFor App (Response ByteString))
-> IO (Response ByteString) -> HandlerFor App (Response ByteString)
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
NH.httpLbs Request
req (Manager -> IO (Response ByteString))
-> IO Manager -> IO (Response ByteString)
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 (Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
res)
     Either String Text -> Handler (Either String Text)
forall a. a -> HandlerFor App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Text
decodeHtmlBs (ByteString -> Text)
-> Either String ByteString -> Either String Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either String ByteString
parseTitle ByteString
body)
     Handler (Either String Text)
-> (SomeException -> Handler (Either String Text))
-> Handler (Either String Text)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\(SomeException
e :: SomeException) -> do
                $(logError) (Text -> Handler ()) -> Text -> Handler ()
forall a b. (a -> b) -> a -> b
$ (String -> Text
[Element Text] -> Text
forall seq. IsSequence seq => [Element seq] -> seq
pack (String -> Text)
-> (SomeException -> String) -> SomeException -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. SomeException -> String
forall a. Show a => a -> String
show) SomeException
e
                Either String Text -> Handler (Either String Text)
forall a. a -> HandlerFor App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Either String Text
forall a b. a -> Either a b
Left (SomeException -> String
forall a. Show a => a -> String
show SomeException
e)))
  where
    parseTitle :: ByteString -> Either String ByteString
parseTitle ByteString
bs =
      (Parser ByteString -> ByteString -> Either String ByteString)
-> ByteString -> Parser ByteString -> Either String ByteString
forall a b c. (a -> b -> c) -> b -> a -> c
flip Parser ByteString -> ByteString -> Either String ByteString
forall a. Parser a -> ByteString -> Either String a
AP.parseOnly ByteString
bs do
        ()
_ <- Parser ByteString -> Parser ByteString ()
forall {a}. Parser ByteString a -> Parser ByteString ()
skipAnyTill (ByteString -> Parser ByteString
AP.string ByteString
"<title")
        ()
_ <- Parser ByteString -> Parser ByteString ()
forall {a}. Parser ByteString a -> Parser ByteString ()
skipAnyTill (ByteString -> Parser ByteString
AP.string ByteString
">")
        let lt :: Word8
lt = Int -> Word8
forall a. Enum a => Int -> a
toEnum (Char -> Int
ord Char
'<')
        (Word8 -> Bool) -> Parser ByteString
AP.takeTill (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
lt)
    decodeHtmlBs :: ByteString -> Text
decodeHtmlBs = Text -> Text
forall lazy strict. LazySequence lazy strict => lazy -> strict
toStrict (Text -> Text) -> (ByteString -> Text) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
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 (Builder -> Text) -> (ByteString -> Builder) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
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 (Text -> Builder) -> (ByteString -> Text) -> ByteString -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> Text
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 Parser ByteString a -> () -> Parser ByteString ()
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> () Parser ByteString ()
-> Parser ByteString () -> Parser ByteString ()
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Word8
AP.anyWord8 Parser Word8 -> Parser ByteString () -> Parser ByteString ()
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
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 " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
action)
  Request -> Handler Request
forall a. a -> HandlerFor App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Request -> Handler Request) -> Request -> Handler Request
forall a b. (a -> b) -> a -> b
$ Request
req
    { NH.requestHeaders = ("Content-Type", "application/x-www-form-urlencoded") : NH.requestHeaders req
    , NH.requestBody =
        NH.RequestBodyLBS $
        WH.urlEncodeAsForm
            ([("submitid", submitId), ("url", href)] :: [(String, String)])
    , NH.redirectCount = 0
    }

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

_archiveUserAgent :: Handler ByteString
_archiveUserAgent :: Handler ByteString
_archiveUserAgent = do
  Maybe ByteString
mHost <- Request -> Maybe ByteString
requestHeaderHost (Request -> Maybe ByteString)
-> (YesodRequest -> Request) -> YesodRequest -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
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 (YesodRequest -> Maybe ByteString)
-> HandlerFor App YesodRequest -> HandlerFor App (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HandlerFor App YesodRequest
forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
  ByteString -> Handler ByteString
forall a. a -> HandlerFor App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Handler ByteString)
-> ByteString -> Handler ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
"espial-" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
-> (ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" ((Char -> Bool) -> ByteString -> ByteString
BS8.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':')) Maybe ByteString
mHost