chandlr-server/app/Main.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Main where

import System.Exit (exitFailure)
import Control.Monad.IO.Class (liftIO)
import Data.Text (Text, pack)
import Data.Text.Lazy (toStrict)
import Miso (ToServerRoutes, View)
import Miso.String (toMisoString)
import           Data.Proxy
import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp             as Wai
import qualified Network.Wai.Middleware.RequestLogger as Wai
import Servant.API
import qualified Servant
import Servant.Server
    ( Server
    , Handler (..)
    , serve
    , err500
    , err404
    , ServerError (..)
    )
import qualified Lucid      as L
import qualified Lucid.Base as L
import qualified Data.ByteString.Lazy as B
import Data.ByteString.Lazy.UTF8 (fromString)
import System.Console.CmdArgs (cmdArgs, Data, Typeable)
import Data.Aeson (decode, ToJSON)
import Data.Aeson.Text (encodeToLazyText)
import Data.Time.Clock (getCurrentTime)
import Control.Monad.Except (throwError)
import Data.Time.Clock (UTCTime)


import JSONSettings
import qualified Common.FrontEnd.Routes as FE
import qualified Common.FrontEnd.Action as FE
import qualified Common.FrontEnd.Model  as FE
import qualified Common.FrontEnd.Views  as FE
import qualified DataClient as Client
import qualified Common.Network.ClientTypes as Client
import qualified Common.Server.JSONSettings as S
import Common.Network.CatalogPostType (CatalogPost)
import qualified Common.Component.CatalogGrid as Grid
import qualified Common.Component.TimeControl as TC
import Common.FrontEnd.Action (GetThreadArgs (..))
import qualified Common.Component.Thread.Model as Thread
import qualified Common.Component.ThreadView as Thread
import Common.Network.SiteType (Site)

data HtmlPage a = forall b. (ToJSON b) => HtmlPage (JSONSettings, b, a)

instance (L.ToHtml a) => L.ToHtml (HtmlPage a) where
    toHtmlRaw = L.toHtml
    toHtml (HtmlPage (settings, initial_data, x)) = do
        L.doctype_
        L.head_ $ do
            L.meta_ [L.charset_ "utf-8"]
            L.meta_ [L.name_ "viewport", L.content_ "width=device-width, initial-scale=1.0"]
            L.meta_ [L.name_ "postgrest-root", L.content_ (pack $ postgrest_url settings)]
            L.meta_ [L.name_ "postgrest-fetch-count", L.content_ (pack $ show $ postgrest_fetch_count settings)]
            L.meta_ [L.name_ "media-root", L.content_ (pack $ media_root settings)]
            L.meta_ [L.name_ "initial-data", L.content_ (toStrict $ encodeToLazyText initial_data) ]

            L.title_ "Chandlr"

            L.link_ [L.rel_ "stylesheet", L.href_ $ static_root <> "/static/style.css"]
            L.script_ [L.src_ $ static_root <> "/dist/build/chandlr/chandlr.jsexe/rts.js", L.makeAttribute "language" "javascript"] ("" :: B.ByteString)
            L.script_ [L.src_ $ static_root <> "/dist/build/chandlr/chandlr.jsexe/lib.js", L.makeAttribute "language" "javascript"] ("" :: B.ByteString)
            L.script_ [L.src_ $ static_root <> "/dist/build/chandlr/chandlr.jsexe/out.js", L.makeAttribute "language" "javascript"] ("" :: B.ByteString)

            L.body_ (L.toHtml x)

            L.script_
                [ L.src_ $ static_root <> "/dist/build/chandlr/chandlr.jsexe/runmain.js"
                , L.makeAttribute "language" "javascript"
                , L.makeAttribute "defer" mempty
                ]
                ("" :: B.ByteString)

        where
            static_root = pack $ static_serve_url_root settings

type FrontEndRoutes = ToServerRoutes FE.Route HtmlPage FE.Action
{-
    :Created By:
      ___________                     _____    ______ 
     /\________  \                   /\  __`\ /\_____\ 
     \/_______//'/'         __   _ __\ \ \/\ \\/_____/ 
             //'/'        /'__`\/\`'__\ \ \ \ \  
            //'/'_______ /\  __/\ \ \/ \ \ \_\ \ 
            /\___________\ \____\\ \_\  \ \_____\
            \/___________/\/____/ \/_/   \/_____/             
-}
 
 

type StaticRoute = "static" :> Servant.Raw

type API = StaticRoute :<|> FrontEndRoutes

handlers :: JSONSettings -> Server FrontEndRoutes
handlers settings
    =    (catalogView settings)
    :<|> (threadView settings)
    :<|> searchView

clientSettings :: JSONSettings -> S.JSONSettings
clientSettings (JSONSettings {..}) = S.JSONSettings
    { S.postgrest_url = postgrest_url
    , S.jwt = jwt
    , S.backup_read_root = undefined
    , S.media_root_path = undefined
    , S.site_name = undefined
    , S.site_url = undefined
    }

clientModel :: JSONSettings -> Client.Model
clientModel (JSONSettings {..}) = Client.Model
    { Client.pgApiRoot = pack postgrest_url
    , Client.fetchCount = postgrest_fetch_count
    }

catalogView :: JSONSettings -> Handler (HtmlPage (View FE.Action))
catalogView settings = do
    now <- liftIO $ getCurrentTime

    catalog_results <- liftIO $ do

        Client.fetchLatest
            (clientSettings settings)
            (clientModel settings)
            now

    case catalog_results of
        Left err -> throwError $ err500 { errBody = fromString $ show err }
        Right posts -> pure $ render now posts

    where
        render :: UTCTime -> [ CatalogPost ] -> HtmlPage (View FE.Action)
        render t posts = HtmlPage (settings, posts, FE.catalogView model)
            where
                model = FE.Model
                    { FE.grid_model = grid_model
                    , FE.client_model = undefined
                    , FE.thread_model = undefined
                    , FE.current_uri = undefined
                    , FE.media_root_ = undefined
                    , FE.current_time = t
                    , FE.tc_model = tc_model
                    , FE.search_model = undefined
                    }

                grid_model = Grid.Model
                    { Grid.display_items = posts
                    , Grid.media_root = toMisoString $ media_root settings
                    }

                tc_model = TC.Model 0

threadView :: JSONSettings -> Text -> Text -> FE.BoardThreadId -> Handler (HtmlPage (View FE.Action))
threadView settings website board_pathpart board_thread_id = do
    thread_results <- liftIO $ do

        Client.getThread
            (clientSettings settings)
            (clientModel settings)
            (GetThreadArgs {..})

    now <- liftIO getCurrentTime

    case thread_results of
        Left err -> throwError $ err500 { errBody = fromString $ show err }
        Right site -> do
            let s = head site
            posts_and_bodies <- liftIO $ Thread.getPostWithBodies s
            pure $ render posts_and_bodies now s

    where
        render :: [ Thread.PostWithBody ] -> UTCTime -> Site -> HtmlPage (View FE.Action)
        render posts_and_bodies t site =
            HtmlPage
                ( settings
                , site
                , FE.threadView website board_pathpart board_thread_id model
                )

            where
                model = FE.Model
                    { FE.grid_model = undefined
                    , FE.client_model = undefined
                    , FE.thread_model = Just thread_model
                    , FE.current_uri = undefined
                    , FE.media_root_ = undefined
                    , FE.current_time = t
                    , FE.tc_model = undefined
                    , FE.search_model = undefined
                    }

                thread_model = Thread.Model
                    { Thread.site = site
                    , Thread.media_root = pack $ media_root settings
                    , Thread.post_bodies = posts_and_bodies
                    , Thread.current_time = t
                    }

searchView :: Maybe Text -> Handler (HtmlPage (View FE.Action))
searchView _ = throwError $ err404 { errBody = "404 - Not Implemented" }

app :: JSONSettings -> Wai.Application
app settings =
    serve
        (Proxy @API)
        (staticHandler :<|> handlers settings)

    where
        staticHandler :: Server StaticRoute
        staticHandler = Servant.serveDirectoryFileServer (static_serve_path settings)

port :: Int
port = 8888

newtype CliArgs = CliArgs
  { settingsFile :: String
  } deriving (Show, Data, Typeable)

getSettings :: IO JSONSettings
getSettings = do
    cliArgs <- cmdArgs $ CliArgs "settings.json"

    let filePath = settingsFile cliArgs
    if null filePath
    then do
        putStrLn "Error: No JSON settings file provided."
        exitFailure
    else do
        putStrLn $ "Loading settings from: " ++ filePath
        content <- B.readFile filePath
        case decode content :: Maybe JSONSettings of
            Nothing -> do
                putStrLn "Error: Invalid JSON format."
                exitFailure
            Just settings -> return settings

main :: IO ()
main = do
    settings <- getSettings
    print settings

    putStrLn $ "Serving front-end on port " ++ show port

    Wai.run port $ Wai.logStdout (app settings)