Compare commits
2 Commits
882d56ce66
...
ff3667516a
Author | SHA1 | Date |
---|---|---|
towards-a-new-leftypol | ff3667516a | |
towards-a-new-leftypol | ad6300fa6b |
|
@ -1 +1 @@
|
||||||
Subproject commit b01e4e269613fc0a69c9728a18a0bcdf1a0562a9
|
Subproject commit b868e4614f3fb56517e65b6965fc011f9190e70d
|
|
@ -0,0 +1,35 @@
|
||||||
|
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)
|
27
app/Main.hs
27
app/Main.hs
|
@ -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 a
|
newtype HtmlPage a = HtmlPage (FE.Model, 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,23 +47,7 @@ catalogView :: Handler (HtmlPage (View FE.Action))
|
||||||
catalogView = do
|
catalogView = do
|
||||||
liftIO $ putStrLn "Hello World"
|
liftIO $ putStrLn "Hello World"
|
||||||
|
|
||||||
pure $ HtmlPage $ h1_ [] [ text "Hello World" ]
|
pure $ HtmlPage (undefined, 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
|
||||||
|
@ -71,9 +55,6 @@ 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
|
||||||
|
|
||||||
|
|
|
@ -66,6 +66,7 @@ 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
|
||||||
|
@ -83,11 +84,14 @@ 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:
|
||||||
|
@ -106,7 +110,12 @@ 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
|
||||||
|
|
|
@ -1,7 +1,11 @@
|
||||||
{ nixpkgs ? import <nixpkgs> {} }:
|
{ nixpkgs ? import <nixpkgs> {} }:
|
||||||
|
|
||||||
let
|
let
|
||||||
drv = nixpkgs.haskell.packages.ghc96.callCabal2nix "chandlr-server" ./. {};
|
http-conduit = import ./app/Common/nix-support/http-conduit.nix { inherit nixpkgs; };
|
||||||
|
|
||||||
|
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 ++ [
|
||||||
|
|
Loading…
Reference in New Issue