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
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)
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
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
get "/" do
_response <- io serve Nothing (_config.index_file_path.encodeUtf8)
State.put _response
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"