content: 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 kbid =
    runDB (get kbid) >>= \case
    Nothing -> pure False
  
    Just bm -> do
      pure $
        isNothing (bookmarkArchiveHref bm) &&
        bookmarkShared bm
        && not (_isArchiveBlacklisted bm)
        && userArchiveDefault user
  
  getArchiveManager :: Handler Manager
  getArchiveManager = do
    appSettings <- appSettings <$> getYesod
    let mSocks =
          NC.SockSettingsSimple <$>
          fmap unpack (appArchiveSocksProxyHost appSettings) <*>
          fmap toEnum (appArchiveSocksProxyPort appSettings)
    NH.newTlsManagerWith (NH.mkManagerSettings def mSocks)
  
  
  archiveBookmarkUrl :: Key Bookmark -> String -> Handler ()
  archiveBookmarkUrl kbid url =
    (_fetchArchiveSubmitInfo >>= \case
      Left e -> do
        $(logError) (pack e)
      Right submitInfo ->  do
          userId <- requireAuthId
          req <- _buildArchiveSubmitRequest submitInfo url
          manager <- getArchiveManager
          res <- liftIO $ NH.httpLbs req manager
          let status = NH.responseStatus res
          let updateArchiveUrl url' = runDB $ updateBookmarkArchiveUrl userId kbid $ Just url'
              headers = NH.responseHeaders res
          case status of
            s | s == NH.status200 ->
              for_ (lookup "Refresh" headers >>= _parseRefreshHeaderUrl) updateArchiveUrl
            s | s == NH.status302 || s == NH.status307 ->
              for_ (lookup "Location" headers) (updateArchiveUrl . decodeUtf8)
            _ -> $(logError) (pack (show res)))
    `catch` (\(e::SomeException) -> ($(logError) $ (pack.show) e) >> throwIO e)
  
  _isArchiveBlacklisted :: Bookmark -> Bool
  _isArchiveBlacklisted Bookmark {..} =
    [ "hulu"
    , "livestream"
    , "netflix"
    , "skillsmatter"
    , "twitch.tv"
    , "vimeo"
    , "youtu.be"
    , "youtube"
    , "archive."
    ] &
    any (`isInfixOf` bookmarkHref)
  
  _parseRefreshHeaderUrl :: ByteString -> Maybe Text
  _parseRefreshHeaderUrl h = do
    let u = BS8.drop 1 $ BS8.dropWhile (/= '=') h
    if not (null u)
      then Just $ decodeUtf8 u
      else Nothing
  
  _fetchArchiveSubmitInfo :: Handler (Either String (String , String))
  _fetchArchiveSubmitInfo = do
    req <- buildRequest "https://archive.li/"
    manager <- getArchiveManager
    res <- liftIO $ NH.httpLbs req manager
    let body = LBS.toStrict (responseBody res)
        action = _parseSubstring (AP8.string "action=\"") (AP8.notChar '"') body
        submitId = _parseSubstring (AP8.string "submitid\" value=\"") (AP8.notChar '"') body
    if statusCode (responseStatus res) == 200
      then pure $ (,) <$> action <*> submitId
      else pure $ Left $ "Invalid statusCode: " <> show (responseStatus res)
  
  
  _parseSubstring :: AP8.Parser ByteString -> AP8.Parser Char -> BS.ByteString -> Either String String
  _parseSubstring start inner = AP8.parseOnly (skipAnyTill start >> AP8.many1 inner)
    where
      skipAnyTill end = go where go = end $> () <|> AP8.anyChar *> go
  
  
  fetchPageTitle :: String -> Handler (Either String Text)
  fetchPageTitle url =
    do
       req <- buildRequest url
       res <- liftIO $ NH.httpLbs req =<< NH.getGlobalManager
       let body = LBS.toStrict (responseBody res)
       pure (decodeHtmlBs <$> parseTitle body)
       `catch` (\(e :: SomeException) -> do
                  $(logError) $ (pack . show) e
                  pure (Left (show e)))
    where
      parseTitle bs =
        flip AP.parseOnly bs do
          _ <- skipAnyTill (AP.string "<title")
          _ <- skipAnyTill (AP.string ">")
          let lt = toEnum (ord '<')
          AP.takeTill (== lt)
      decodeHtmlBs = toStrict . toLazyText . htmlEncodedText . decodeUtf8
      skipAnyTill end = go where go = end $> () <|> AP.anyWord8 *> go
  
  _buildArchiveSubmitRequest :: (String, String) -> String -> Handler NH.Request
  _buildArchiveSubmitRequest (action, submitId) href = do
    req <- buildRequest ("POST " <> action)
    pure $ 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 url = do
    ua <- _archiveUserAgent
    pure $ NH.parseRequest_ url & \r ->
      r { NH.requestHeaders =
            [ ("Cache-Control", "max-age=0")
            , ("User-Agent", ua)
            ]
        }
  
  _archiveUserAgent :: Handler ByteString
  _archiveUserAgent = do
    mHost <- requestHeaderHost . reqWaiRequest <$> getRequest
    pure $ "espial-" <> maybe "" (BS8.takeWhile (/= ':')) mHost
  
  