<commit_before>{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts   #-}
{-# LANGUAGE AllowAmbiguousTypes #-}

module Web.Offset.Splices where

import           Control.Monad.State
import           Control.Applicative     ((<|>))
import           Control.Lens            hiding (children)
import           Control.Concurrent.MVar
import           Data.Aeson              hiding (decode, encode, json, object)
import qualified Data.Attoparsec.Text    as A
import           Data.Char               (toUpper)
import qualified Data.HashMap.Strict     as M
import qualified Data.Map as Map
import           Data.IntSet             (IntSet)
import qualified Data.IntSet             as IntSet
import           Data.Maybe              (fromJust, fromMaybe, catMaybes)
import           Data.Monoid
import           Data.Scientific         (floatingOrInteger)
import qualified Data.Set                as Set
import           Data.Text               (Text)
import qualified Data.Text               as T
import qualified Data.Vector             as V
import           Web.Larceny

import           Web.Offset.Field
import           Web.Offset.Posts
import           Web.Offset.Queries
import           Web.Offset.Date
import           Web.Offset.Types
import           Web.Offset.Utils

wordpressSubs ::   Wordpress b
              -> [Field s]
              -> StateT s IO Text
              -> WPLens b s
              -> Substitutions s
wordpressSubs wp extraFields getURI wpLens =
  subs [ ("wpPosts", wpPostsFill wp extraFields wpLens)
       , ("wpPostByPermalink", wpPostByPermalinkFill extraFields getURI wpLens)
       , ("wpPage", wpPageFill wpLens)
       , ("wpNoPostDuplicates", wpNoPostDuplicatesFill wpLens)
       , ("wp", wpPrefetch wp extraFields getURI wpLens)
       , ("wpCustom", wpCustomFill wp)
       , ("wpCustomDate", wpCustomDateFill)
       , ("stripHtml", stripHtmlFill)]

stripTags :: Text -> Text
stripTags ""         = ""
stripTags str = case (T.take 1 str) of
  "<" -> stripTags $ T.drop 1 $ T.dropWhile (/= '>') str
  _ -> (T.take 1 str) <> stripTags (T.drop 1 str)

stripHtmlFill :: Fill s
stripHtmlFill = Fill $ \attrs (path, tpl) lib -> do
  text <- runTemplate tpl path mempty lib
  return $ stripTags text

wpCustomDateFill :: Fill s
wpCustomDateFill =
  useAttrs (a "wp_format" % a "date") customDateFill
  where customDateFill mWPFormat date =
          let wpFormat = fromMaybe "%Y-%m-%d %H:%M:%S" mWPFormat in
          case parseWPDate wpFormat date of
              Just d -> fillChildrenWith $ datePartSubs d
              Nothing -> rawTextFill $ "<!-- Unable to parse date: " <> date <> " -->"

wpCustomFill :: Wordpress b -> Fill s
wpCustomFill wp =
  useAttrs (a "endpoint") (customFill wp)

customFill :: Wordpress b -> Text -> Fill s
customFill Wordpress{..} endpoint = Fill $ \attrs (path, tpl) lib ->
  do let key = EndpointKey endpoint
     res <- liftIO $ cachingGetRetry key
     case fmap decode res of
       Left code -> do
         let notification = "Encountered status code " <> tshow code
                         <> " when querying \"" <> endpoint <> "\"."
         liftIO $ wpLogger notification
         return $ "<!-- " <> notification <> " -->"
       Right (Just (json :: Value)) ->
         unFill (jsonToFill json) attrs (path, tpl) lib
       Right Nothing -> do
         let notification = "Unable to decode JSON for endpoint \"" <> endpoint
         liftIO $ wpLogger $ notification <> ": " <> tshow res
         return $ "<!-- " <> notification <> "-->"

jsonToFill :: Value -> Fill s
jsonToFill (Object o) =
  Fill $ \_ (path, tpl) lib -> runTemplate tpl path objectSubstitutions lib
  where objectSubstitutions =
          subs $ map (\k -> (transformName k,
                             jsonToFill (fromJust (M.lookup k o))))
                     (M.keys o)
jsonToFill (Array v) =
  Fill $ \attrs (path, tpl) lib ->
           V.foldr mappend "" <$> V.mapM (\e -> unFill (jsonToFill e) attrs (path, tpl) lib) v
jsonToFill (String s) = rawTextFill s
jsonToFill (Number n) = case floatingOrInteger n of
                          Left r -> rawTextFill $ tshow (r :: Double)
                          Right i -> rawTextFill $ tshow (i :: Integer)
jsonToFill (Bool True) = rawTextFill $ tshow True
jsonToFill (Bool False) = rawTextFill "<!-- JSON field found, but value is false. -->"
jsonToFill (Null) = rawTextFill "<!-- JSON field found, but value is null. -->"


wpPostsFill :: Wordpress b
            -> [Field s]
            -> WPLens b s
            -> Fill s
wpPostsFill wp extraFields wpLens = Fill $ \attrs tpl lib ->
  do let postsQuery = parseQueryNode (Map.toList attrs)
     filters <- liftIO $ mkFilters wp (qtaxes postsQuery)
     let wpKey = mkWPKey filters postsQuery
     res <- liftIO $ cachingGetRetry wp wpKey
     case fmap decode res of
       Right (Just posts) -> do
         let postsW = extractPostIds posts
         wp' <- use wpLens
         let postsND = take (qlimit postsQuery)
                       . noDuplicates (requestPostSet wp') $ postsW
         addPostIds wpLens (map fst postsND)
         unFill (wpPostsHelper wp extraFields (map snd postsND)) mempty tpl lib
       Right Nothing -> return ""
       Left code -> do
         let notification = "Encountered status code " <> tshow code
                            <> " when querying wpPosts."
         liftIO $ wpLogger wp notification
         return $ "<!-- " <> notification <> " -->"
  where noDuplicates :: Maybe IntSet -> [(Int, Object)] -> [(Int, Object)]
        noDuplicates Nothing = id
        noDuplicates (Just wpPostIdSet) = filter (\(wpId,_) -> IntSet.notMember wpId wpPostIdSet)

mkFilters :: Wordpress b -> [TaxSpecList] -> IO [Filter]
mkFilters wp specLists =
  concat <$> mapM (\(TaxSpecList tName list) -> catMaybes <$> mapM (toFilter tName) list) specLists
  where toFilter :: TaxonomyName -> TaxSpec -> IO (Maybe Filter)
        toFilter tName tSpec = do
          mTSpecId <- lookupSpecId wp tName tSpec<commit_msg>Refactor wpPostsFill to allow for less duplication<commit_after>{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts   #-}
{-# LANGUAGE AllowAmbiguousTypes #-}

module Web.Offset.Splices where

import           Control.Monad.State
import           Control.Applicative     ((<|>))
import           Control.Lens            hiding (children)
import           Control.Concurrent.MVar
import           Data.Aeson              hiding (decode, encode, json, object)
import qualified Data.Attoparsec.Text    as A
import           Data.Char               (toUpper)
import qualified Data.HashMap.Strict     as M
import qualified Data.Map as Map
import           Data.IntSet             (IntSet)
import qualified Data.IntSet             as IntSet
import           Data.Maybe              (fromJust, fromMaybe, catMaybes)
import           Data.Monoid
import           Data.Scientific         (floatingOrInteger)
import qualified Data.Set                as Set
import           Data.Text               (Text)
import qualified Data.Text               as T
import qualified Data.Vector             as V
import           Web.Larceny

import           Web.Offset.Field
import           Web.Offset.Posts
import           Web.Offset.Queries
import           Web.Offset.Date
import           Web.Offset.Types
import           Web.Offset.Utils

wordpressSubs ::   Wordpress b
              -> [Field s]
              -> StateT s IO Text
              -> WPLens b s
              -> Substitutions s
wordpressSubs wp extraFields getURI wpLens =
  subs [ ("wpPosts", wpPostsFill wp extraFields wpLens)
       , ("wpPostByPermalink", wpPostByPermalinkFill extraFields getURI wpLens)
       , ("wpPage", wpPageFill wpLens)
       , ("wpNoPostDuplicates", wpNoPostDuplicatesFill wpLens)
       , ("wp", wpPrefetch wp extraFields getURI wpLens)
       , ("wpCustom", wpCustomFill wp)
       , ("wpCustomDate", wpCustomDateFill)
       , ("stripHtml", stripHtmlFill)]

stripTags :: Text -> Text
stripTags ""         = ""
stripTags str = case (T.take 1 str) of
  "<" -> stripTags $ T.drop 1 $ T.dropWhile (/= '>') str
  _ -> (T.take 1 str) <> stripTags (T.drop 1 str)

stripHtmlFill :: Fill s
stripHtmlFill = Fill $ \attrs (path, tpl) lib -> do
  text <- runTemplate tpl path mempty lib
  return $ stripTags text

wpCustomDateFill :: Fill s
wpCustomDateFill =
  useAttrs (a "wp_format" % a "date") customDateFill
  where customDateFill mWPFormat date =
          let wpFormat = fromMaybe "%Y-%m-%d %H:%M:%S" mWPFormat in
          case parseWPDate wpFormat date of
              Just d -> fillChildrenWith $ datePartSubs d
              Nothing -> rawTextFill $ "<!-- Unable to parse date: " <> date <> " -->"

wpCustomFill :: Wordpress b -> Fill s
wpCustomFill wp =
  useAttrs (a "endpoint") (customFill wp)

customFill :: Wordpress b -> Text -> Fill s
customFill Wordpress{..} endpoint = Fill $ \attrs (path, tpl) lib ->
  do let key = EndpointKey endpoint
     res <- liftIO $ cachingGetRetry key
     case fmap decode res of
       Left code -> do
         let notification = "Encountered status code " <> tshow code
                         <> " when querying \"" <> endpoint <> "\"."
         liftIO $ wpLogger notification
         return $ "<!-- " <> notification <> " -->"
       Right (Just (json :: Value)) ->
         unFill (jsonToFill json) attrs (path, tpl) lib
       Right Nothing -> do
         let notification = "Unable to decode JSON for endpoint \"" <> endpoint
         liftIO $ wpLogger $ notification <> ": " <> tshow res
         return $ "<!-- " <> notification <> "-->"

jsonToFill :: Value -> Fill s
jsonToFill (Object o) =
  Fill $ \_ (path, tpl) lib -> runTemplate tpl path objectSubstitutions lib
  where objectSubstitutions =
          subs $ map (\k -> (transformName k,
                             jsonToFill (fromJust (M.lookup k o))))
                     (M.keys o)
jsonToFill (Array v) =
  Fill $ \attrs (path, tpl) lib ->
           V.foldr mappend "" <$> V.mapM (\e -> unFill (jsonToFill e) attrs (path, tpl) lib) v
jsonToFill (String s) = rawTextFill s
jsonToFill (Number n) = case floatingOrInteger n of
                          Left r -> rawTextFill $ tshow (r :: Double)
                          Right i -> rawTextFill $ tshow (i :: Integer)
jsonToFill (Bool True) = rawTextFill $ tshow True
jsonToFill (Bool False) = rawTextFill "<!-- JSON field found, but value is false. -->"
jsonToFill (Null) = rawTextFill "<!-- JSON field found, but value is null. -->"


wpPostsFill :: Wordpress b
            -> [Field s]
            -> WPLens b s
            -> Fill s
wpPostsFill wp extraFields wpLens = Fill $ \attrs tpl lib ->
  do (postsQuery, wpKey) <- mkPostsQueryAndKey wp attrs
     res <- liftIO $ cachingGetRetry wp wpKey
     case fmap decode res of
       Right (Just posts) -> do
         postsND <- postsWithoutDuplicates wpLens postsQuery posts
         addPostIds wpLens (map fst postsND)
         unFill (wpPostsHelper wp extraFields (map snd postsND)) mempty tpl lib
       Right Nothing -> return ""
       Left code     -> liftIO $ logStatusCode wp code

postsWithoutDuplicates :: WPLens b s
                       -> WPQuery
                       -> [Object]
                       -> StateT s IO [(Int, Object)]
postsWithoutDuplicates wpLens postsQuery posts = do
  wp <- use wpLens
  let postsW = extractPostIds posts
  return $ take (qlimit postsQuery) . removeDupes (requestPostSet wp) $ postsW
  where removeDupes :: Maybe IntSet -> [(Int, Object)] -> [(Int, Object)]
        removeDupes Nothing = id
        removeDupes (Just wpPostIdSet) =
          filter (\(wpId,_) -> IntSet.notMember wpId wpPostIdSet)

mkPostsQueryAndKey :: Wordpress b
                   -> Attributes
                   -> StateT s IO (WPQuery, WPKey)
mkPostsQueryAndKey wp attrs = do
  let postsQuery = parseQueryNode (Map.toList attrs)
  filters <- liftIO $ mkFilters wp (qtaxes postsQuery)
  let wpKey = mkWPKey filters postsQuery
  return (postsQuery, wpKey)

logStatusCode :: Wordpress b -> Int -> IO Text
logStatusCode wp code = do
  let notification = "Encountered status code " <> tshow code
                     <> " when querying wpPosts."
  wpLogger wp notification
  return $ "<!-- " <> notification <> " -->"
mkFilters :: Wordpress b -> [TaxSpecList] -> IO [Filter]
mkFilters wp specLists =
  concat <$> mapM (\(TaxSpecList tName list) -> catMaybes <$> mapM (toFilter tName) list) specLists
  where toFilter :: TaxonomyName -> TaxSpec -> IO (Maybe Filter)
        toFilter tName tSpec = do
          mTSpecId <- lookupSpecId wp tName tSpec
{'fraction_non_alphanumeric': 0.10328675150284956, 'fraction_numerical': 0.0006245608556483723, 'mean_word_length': 2.169223156853043, 'pattern_counts': {'":': 2, '<': 75, '<?xml version=': 0, '>': 146, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '7627602', 'n_tokens_mistral': 3783, 'n_tokens_neox': 3684, 'n_words': 1210}