{-# 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.Spec
import Air.TH (mkDefault, here)
import Control.Concurrent.Chan
import Control.Monad hiding (join, get)
import Control.Monad.Reader (ask)
import Data.Aeson.Encode.Pretty (encodePretty)
import Data.Aeson.Generic (encode, decode)
import Data.Aeson.Generic (toJSON)
import Data.Function (on)
import Data.IORef
import Data.List (find, sort)
import Data.List (sortBy)
import Data.Map (Map)
import Data.Map (toAscList)
import Data.Maybe (fromMaybe, catMaybes)
import Data.Text (Text)
import Data.Text.Encoding
import Data.Time (formatTime, fromGregorianValid, UTCTime(..))
import Data.UUID (toString)
import Filesystem.Path.CurrentOS (encodeString, decodeString)
import Hack2 (Application, Middleware)
import Hack2.Contrib.Middleware.File (serve)
import Hack2.Contrib.Middleware.Static
import Hack2.Contrib.Request (params)
import Hack2.Contrib.Response
import Hack2.Contrib.Utils (use, unescape_uri, query_string)
import Network.Miku hiding (json)
import Network.Miku.Type (AppMonadT)
import Safe (readMay)
import System.Directory
import System.FSNotify
import System.FilePath
import System.FilePath.Glob
import System.Locale (defaultTimeLocale)
import System.Random
import Test.Hspec
import Text.Printf
import Web.Geek.Config
import Web.Geek.DefaultConfig
import Web.Geek.Post
import Web.Geek.Runtime
import Web.Geek.Type
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 Data.Text.IO as TextIO
import qualified Network.Miku as Miku
import qualified Prelude as P
import qualified Prelude as P


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 :: AppMonadT [Post]
    read_posts = io - readIORef - runtime.posts_ref

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

          let _lowered_query_text = ICU.toLower ICU.Current _query_text

              _number_of_maximum_tokens = 7

              _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
  in
  
  miku - do
    get "/posts" - do
      _params <- ask ^ params
      
      
      let tag_string = _params.(lookup "tag" > fromMaybe "" > B.unpack > b2u)
          tag_text = tag_string.T.pack.T.strip
          
      
      _query_text <- query_text
      
      -- io - printf "query_text: %s" (T.unpack _query_text)
      
      _posts_filtered_by_query <- filter_posts_by_query _query_text
      
      _posts_filtered_by_tag_and_query <-
        if tag_text.T.null
          then do
            -- io - puts "no tag"
            return _posts_filtered_by_query
          else do
            -- io - puts - "tag: " + show tag_text
            return - _posts_filtered_by_query.select (tags > has tag_text)
      
      (_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 <- captures

      posts <- read_posts
      
      
      
      let 
        _post = fromMaybe def - do
          year <- _captures.lookup "year" >>= B.unpack > readMay
          month <- _captures.lookup "month" >>= B.unpack > readMay
          day <- _captures.lookup "day" >>= B.unpack > readMay
          _title <- _captures.lookup "title" >>= B.unpack > unescape_uri > T.pack > return
        
          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 <- filter_posts_by_query _query_text
      
      _posts <- 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
      
    {-
    get "/post/:title" - do
      _captures <- captures
      posts <- read_posts

      let 
        _post = fromMaybe def - do
          _title <- _captures.lookup "title" >>= B.unpack > unescape_uri > T.pack > return
          posts.find (title > is _title)


      json _post

    -}
    
    get "*" - do
      text "Unknown route"
  
register_monitor :: WatchManager -> FilePath -> (FilePath -> IO ()) -> IO ()
register_monitor manager path callback = do
  -- printf "reigister_with_path: %s\n" path
  -- 
  watchTree manager (decodeString path) (const True) (\event -> do
    -- puts - show event
    action event
    )
  where
    action (Added _path time) = callback - encodeString _path
    action (Modified _path time) = callback - encodeString _path
    action (Removed _path time) = callback - encodeString _path



-- Spec

test_meta :: String
test_meta = [here|

---
layout: post
categories: 日常
---

|]

spec :: Spec
spec = do
  describe "Server" - do
    let _config = default_config
    
    it "should list posts" - do
      posts <- get_posts _config []
      
      posts `shouldSatisfy` (null > not)
    
      
    it "should callback on change" - do
      let tmp_path = "tmp"
      test_id <- randomIO ^ toString
      let test_path = tmp_path / test_id
    
      createDirectoryIfMissing True test_path
      
      watch_manager <- startManager
      path_chan <- newChan
      
      register_monitor watch_manager test_path - \file_path -> do
        -- puts - printf "Changed: %s" file_path
        writeChan path_chan file_path 
      
      let test_case_id = "callback"
          test_case_path = test_path / test_case_id

      B.writeFile test_case_path "Hello"
      sleep 0.1
      event_paths <- getChanContents path_chan
      stopManager watch_manager
      
      test_case_full_path <- canonicalizePath test_case_path
      removeDirectoryRecursive test_path
      
      event_paths `shouldSatisfy` (has test_case_full_path)