Compare commits

..

No commits in common. "ff3667516af3fbfbf30c5d6b556364e5d808957a" and "882d56ce662f55c8d2779f4c401c79106abcbd92" have entirely different histories.

5 changed files with 26 additions and 55 deletions

@ -1 +1 @@
Subproject commit b868e4614f3fb56517e65b6965fc011f9190e70d Subproject commit b01e4e269613fc0a69c9728a18a0bcdf1a0562a9

View File

@ -1,35 +0,0 @@
module DataClient
( fetchLatest
)
where
import Data.Time.Clock (UTCTime)
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.Char8 as LC8
import Common.Network.CatalogPostType (CatalogPost)
import Common.Network.ClientTypes (Model (..), FetchCatalogArgs (..))
import Common.Network.HttpClient
( post
, HttpError (..)
)
import Data.Aeson (eitherDecode, encode, FromJSON)
import Common.Server.JSONSettings (JSONSettings)
fetchLatest :: JSONSettings -> Model -> UTCTime -> IO (Either HttpError [ CatalogPost ])
fetchLatest settings m t = do
post settings "/rpc/fetch_catalog" payload False >>= return . eitherDecodeResponse
where
payload = encode FetchCatalogArgs
{ max_time = t
, max_row_read = fetchCount m
}
eitherDecodeResponse :: (FromJSON a) => Either HttpError LBS.ByteString -> Either HttpError a
eitherDecodeResponse (Left err) = Left err
eitherDecodeResponse (Right bs) =
case eitherDecode bs of
Right val -> Right val
Left err -> Left $ StatusCodeError 500 $ LC8.pack $ "Failed to decode JSON: " ++ err ++ " " ++ (show bs)

View File

@ -12,18 +12,18 @@ import qualified Network.Wai.Middleware.RequestLogger as Wai
import Servant.API import Servant.API
import Servant.Server (Server, Handler (..), serve) import Servant.Server (Server, Handler (..), serve)
import qualified Lucid as L import qualified Lucid as L
-- import qualified Lucid.Base as L import qualified Lucid.Base as L
import qualified Common.FrontEnd.Routes as FE import qualified Common.FrontEnd.Routes as FE
import qualified Common.FrontEnd.Action as FE import qualified Common.FrontEnd.Action as FE
import qualified Common.FrontEnd.Model as FE import qualified Common.FrontEnd.Model as FE
newtype HtmlPage a = HtmlPage (FE.Model, a) newtype HtmlPage a = HtmlPage a
instance (L.ToHtml a) => L.ToHtml (HtmlPage a) where instance (L.ToHtml a) => L.ToHtml (HtmlPage a) where
toHtmlRaw = L.toHtml toHtmlRaw = L.toHtml
toHtml (HtmlPage (_, x)) = L.toHtml x toHtml (HtmlPage x) = L.toHtml x
-- toHtml (HtmlPage x) = do -- toHtml (HtmlPage x) = do
-- L.doctype_ -- L.doctype_
-- L.head_ $ do -- L.head_ $ do
@ -47,7 +47,23 @@ catalogView :: Handler (HtmlPage (View FE.Action))
catalogView = do catalogView = do
liftIO $ putStrLn "Hello World" liftIO $ putStrLn "Hello World"
pure $ HtmlPage (undefined, h1_ [] [ text "Hello World" ]) pure $ HtmlPage $ h1_ [] [ text "Hello World" ]
{-
return $ HtmlPage $ do
L.doctype_
L.head_ $ do
L.title_ "Chandlr"
L.meta_ [L.charset_ "utf-8"]
L.with (L.script_ mempty)
[ L.makeAttribute "src" "/static/all.js"
, L.makeAttribute "async" mempty
, L.makeAttribute "defer" mempty
]
L.body_ (L.h1_ "Hello World")
-}
threadView :: Text -> Text -> FE.BoardThreadId -> Handler (HtmlPage (View FE.Action)) threadView :: Text -> Text -> FE.BoardThreadId -> Handler (HtmlPage (View FE.Action))
threadView = undefined threadView = undefined
@ -55,6 +71,9 @@ threadView = undefined
searchView :: Maybe Text -> Handler (HtmlPage (View FE.Action)) searchView :: Maybe Text -> Handler (HtmlPage (View FE.Action))
searchView = undefined searchView = undefined
viewPage :: FE.Model -> View FE.Action
viewPage = undefined
app :: Wai.Application app :: Wai.Application
app = serve (Proxy @FrontEndRoutes) handlers app = serve (Proxy @FrontEndRoutes) handlers

View File

@ -66,7 +66,6 @@ executable chandlr-server
Common.Component.Search.SearchTypes Common.Component.Search.SearchTypes
Common.FrontEnd.Action Common.FrontEnd.Action
Common.FrontEnd.Routes Common.FrontEnd.Routes
Common.FrontEnd.Model
Common.Network.CatalogPostType Common.Network.CatalogPostType
Common.Network.ClientTypes Common.Network.ClientTypes
Common.Network.HttpTypes Common.Network.HttpTypes
@ -84,14 +83,11 @@ executable chandlr-server
Common.Network.SiteType Common.Network.SiteType
Common.Network.ThreadType Common.Network.ThreadType
Common.Network.Units Common.Network.Units
Common.Network.HttpClient
Common.Parsing.EmbedParser Common.Parsing.EmbedParser
Common.Parsing.PostBodyUtils Common.Parsing.PostBodyUtils
Common.Parsing.PostPartType Common.Parsing.PostPartType
Common.Parsing.QuoteLinkParser Common.Parsing.QuoteLinkParser
Parsing.BodyParser Parsing.BodyParser
DataClient
Common.Server.JSONSettings
-- LANGUAGE extensions used by modules in this package. -- LANGUAGE extensions used by modules in this package.
-- other-extensions: -- other-extensions:
@ -110,12 +106,7 @@ executable chandlr-server
containers, containers,
servant, servant,
servant-server, servant-server,
lucid, lucid
safe-exceptions,
bytestring,
http-conduit,
http-client,
http-types
-- Directories containing source files. -- Directories containing source files.
hs-source-dirs: app hs-source-dirs: app

View File

@ -1,11 +1,7 @@
{ nixpkgs ? import <nixpkgs> {} }: { nixpkgs ? import <nixpkgs> {} }:
let let
http-conduit = import ./app/Common/nix-support/http-conduit.nix { inherit nixpkgs; }; drv = nixpkgs.haskell.packages.ghc96.callCabal2nix "chandlr-server" ./. {};
drv = nixpkgs.haskellPackages.callCabal2nix "chandlr-server" ./. {
http-conduit = http-conduit.http-conduit;
};
env = drv.env.overrideAttrs (oldAttrs: { env = drv.env.overrideAttrs (oldAttrs: {
buildInputs = oldAttrs.buildInputs ++ [ buildInputs = oldAttrs.buildInputs ++ [