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


module Web.Geek.Application where

import Air.Data.Record.SimpleLabel hiding (get)
import Air.Env
import Air.Extra hiding (date)
import Air.TH (here)
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)
import Hack2.Contrib.Utils (use, unescape_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
      
      -- io - printf "query_text: %s" (T.unpack _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
      
      -- io - puts - paginated_posts.map (title > T.unpack).join "\n"
      
          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)
      
      -- io - print tag_data_list
      json tag_data_list

    get "/" - do
      -- modify - redirect "/index.html" Nothing

      _response <- io - serve Nothing (_config.index_file_path.encodeUtf8)

      State.put _response
      
    
    -- Feeds
    
    
    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 _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
    
    get "*" - do
      text "Unknown route"