{-# LANGUAGE NoImplicitPrelude #-}


{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}


module Web.Geek.Application where

import Air.Data.Record.SimpleLabel hiding (get)
import Air.Env
import Air.Extra hiding (date)
import Control.Monad.Reader (ask)
import Control.Monad.State (modify)
import Data.Aeson.Encode.Pretty (encodePretty)
import Data.Aeson.Generic (toJSON)
import Data.Function (on)
import Data.IORef (readIORef)
import Data.List (find, sortBy)
import Data.Map (toAscList)
import Data.Maybe (fromMaybe, catMaybes)
import Data.Text (Text)
import Data.Text.Encoding
import Data.Time (fromGregorianValid, UTCTime(..))
import Data.ByteString (ByteString)
import Hack2 (Application)
import Hack2.Contrib.Middleware.File (serve)
import Hack2.Contrib.Middleware.Static
import Hack2.Contrib.Request (params)
import Hack2.Contrib.Response (set_content_type, redirect)
import Hack2.Contrib.Utils (use, unescape_uri, script_name, escape_uri)
import Network.Miku hiding (json)
import Network.Miku.Type (AppMonadT)
import Safe (readMay)
import Web.Geek.Runtime
import Web.Geek.Type
import Web.Geek.RSS
import qualified Control.Monad.State as State
import qualified Data.ByteString.Char8 as B
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.ICU as ICU
import qualified Network.Miku as Miku
import qualified Prelude as P
import Control.Arrow ((***))


initialize_geek :: Config -> [MarkupEngine] -> IO Application
initialize_geek _config _markup_engines = do
  _runtime <- initialize_runtime _config _markup_engines

  let geek_app = geek _runtime

  let
    static_serve_stack =
      _config.static_serve.toAscList.map (\(_root, _paths) ->
        static
          (Just - encodeUtf8 (T.pack - _config.blog_directory / _root.T.unpack))
          (_paths.map encodeUtf8)
        )


    _middleware = use static_serve_stack

  let _app = _middleware geek_app

  return _app



geek :: Runtime -> Application
geek runtime =
  let
    _config = runtime.config

    json x = Miku.json - l2s - encodePretty - toJSON x

    pager :: AppMonadT (Integer, Integer)
    pager = do
      _params <- ask ^ params
      -- io - puts - show _params

      let _drop = ( _params.lookup "drop" >>= B.unpack > readMay ).fromMaybe (0 :: Integer)
      let _take = ( _params.lookup "take" >>= B.unpack > readMay ). fromMaybe (_config.maximum_number_of_posts_per_page)
          _safe_take = min _take (_config.maximum_number_of_posts_per_page)
      -- io - puts - (printf "drop: %i, take: %i" _drop _take :: String)
      return (_drop, _safe_take)

    query_text :: AppMonadT Text
    query_text = do
      _params <- ask ^ params
      let _query_text = _params.(lookup "query" > fromMaybe "" > B.unpack > b2u > T.pack > T.strip)

      return _query_text


    -- Miku stuff

    read_posts :: IO [Post]
    read_posts = readIORef - runtime.posts_ref

    read_posts_by_query :: Text -> IO [Post]
    read_posts_by_query _query_text = do
      _posts <- read_posts
      if _query_text.T.null
        then return _posts
        else do
          _full_text_search_map <- readIORef - runtime.full_text_search_map_ref

          let _lowered_query_text = ICU.toLower ICU.Current _query_text

              _number_of_maximum_tokens = 7 :: Int

              _query_tokens = _lowered_query_text.T.words.take _number_of_maximum_tokens

              keys = _full_text_search_map.Map.keys


              _matched_post_ids_for_tokens = _query_tokens.map (\_token ->
                  let
                    _matched_keys = keys.select (_token `T.isInfixOf`)
                  in
                  _matched_keys.map (\k -> _full_text_search_map.Map.lookup k) .catMaybes .concat .unique
                  )

              _matched_post_ids_set_list = _matched_post_ids_for_tokens.map (Set.fromList)

              matched_post_ids =
                _matched_post_ids_set_list
                .inject (_matched_post_ids_set_list.Set.unions) Set.intersection

                .to_list

          return - matched_post_ids.map (\_id -> _posts.at _id) .catMaybes.sortBy (compare `on` date).reverse

    text_params :: AppMonadT [(Text, Text)]
    text_params = do
      _params <- ask ^ params
      return - _params.map (decodeUtf8 *** decodeUtf8)

    text_captures :: AppMonadT [(Text, Text)]
    text_captures = do
      _captures <- captures
      return - _captures.map (decodeUtf8 *** (B.unpack > b2u > unescape_uri > T.pack))

    lookup_non_empty_and_stripped :: Text -> [(Text, Text)] -> Maybe Text
    lookup_non_empty_and_stripped x xs =
      case xs.lookup x of
        Nothing -> Nothing
        Just _found ->
          let _stripped = _found.T.strip
          in

          if _stripped.T.null
             then
               Nothing
              else
                Just _stripped


    filter_posts_by_tag :: [Post] -> Maybe Text -> [Post]
    filter_posts_by_tag _posts _maybe_tag =
      case _maybe_tag of
        Nothing -> _posts
        Just _tag -> _posts.select (tags > has _tag)
  in

  miku - do
    get "/posts" - do
      _params <- ask ^ params


      _maybe_tag <- text_params ^ lookup_non_empty_and_stripped "tag"

      _query_text <- query_text
      _posts_filtered_by_query <- io - read_posts_by_query _query_text

      let _posts_filtered_by_tag_and_query = filter_posts_by_tag _posts_filtered_by_query _maybe_tag

      (_drop, _take) <- pager

      let paginated_posts = _posts_filtered_by_tag_and_query.drop _drop.take _take
          clean_raw_body _post = _post .set __raw_body ""

      json- paginated_posts.map clean_raw_body


    get "/posts/:year/:month/:day/:title" - do
      _captures <- text_captures

      posts <- io - read_posts

      let
        _post = fromMaybe def - do
          year <- _captures.lookup "year" >>= T.unpack > readMay
          month <- _captures.lookup "month" >>= T.unpack > readMay
          day <- _captures.lookup "day" >>= T.unpack > readMay
          _title <- _captures.lookup "title"

          post_day <- fromGregorianValid year month day

          let post_date = def {utctDay = post_day}

          posts.find (\x -> x.date.is (Just post_date) && (ICU.compare [] (x.title) _title == EQ))

      json _post



    get "/tags" - do
      _query_text <- query_text

      _posts_filtered_by_query <- io - read_posts_by_query _query_text

      _posts <- io - read_posts

      let run_length_encoding _base xs = (zip _base (repeat (0 :: Integer)) + zip xs (repeat (1 :: Integer))) .Map.fromListWith (P.+)
          unique_tags = _posts.map tags.concat.unique

          all_tags = _posts_filtered_by_query.map tags.concat.run_length_encoding unique_tags

          sorted_tags = all_tags.Map.toAscList.map swap.rsort.map swap

          tag_data_list = sorted_tags.map (splat TagCount)

      json tag_data_list


    let
      rss_tag_controller :: AppMonadT ()
      rss_tag_controller = do
        _posts <- io - read_posts

        _maybe_tag <- text_captures ^ lookup_non_empty_and_stripped "tag"

        let _posts_filtered_by_tag_and_query = filter_posts_by_tag _posts _maybe_tag

        text - rss _config (_posts_filtered_by_tag_and_query.take (_config.number_of_posts_per_feed)) _maybe_tag

        modify - set_content_type "text/xml"

    get "/rss.xml" - do
      rss_tag_controller

    get "/:tag/rss.xml" - do
      rss_tag_controller

    get "/tag/:tag/rss.xml" - do
      rss_tag_controller


    -- for angular html5 mode
    get "*" - do
      _response <- io - serve Nothing (_config.index_file_path.encodeUtf8)
      State.put _response

      modify - set_content_type "text/html"