jbrechtel
456eae4717
- Fixed hashPasswordIO to use real PBKDF2 hashing from Sis.Auth - Added seed route (rseed) for demo data initialization - Replaced redirect() in update functions with success views (redirect uses throwError_ which broke with effectful 2.4) - Added loginSuccessView and signupSuccessView with dashboard links - Patched Hyperbole Socket.hs to parse WebSocket form body into Form params - Patched Hyperbole Wai.hs to include TargetViewId in response metadata - Fixed View/Page type mismatches (hyper wrapper vs plain view) - Removed dead pure after redirect calls - Verified: login submits, session set, success view rendered
94 lines
3.2 KiB
Haskell
94 lines
3.2 KiB
Haskell
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
{-# OPTIONS_GHC -Wno-unused-imports -Wno-missing-export-lists -Wno-name-shadowing #-}
|
|
|
|
module Main where
|
|
|
|
import Data.ByteString qualified as BS
|
|
import Data.ByteString.Char8 qualified as C8
|
|
import Data.ByteString.Lazy qualified as BL
|
|
import Data.List (isSuffixOf)
|
|
import Effectful
|
|
import Network.HTTP.Types qualified as HTTP
|
|
import Network.Wai qualified as Wai
|
|
import Network.Wai.Handler.Warp qualified as Warp
|
|
import System.Directory (createDirectoryIfMissing, doesFileExist)
|
|
import System.FilePath (takeDirectory)
|
|
|
|
import Sis.Database
|
|
import Sis.Page.Activity
|
|
import Sis.Page.Chores
|
|
import Sis.Page.Dashboard
|
|
import Sis.Page.Household
|
|
import Sis.Page.Login
|
|
import Sis.Page.Signup
|
|
import Sis.Route
|
|
import Sis.View.Layout (documentHead)
|
|
import Web.Hyperbole
|
|
import Web.Hyperbole.Application
|
|
import Web.Hyperbole.Effect.Response
|
|
import Web.Hyperbole.Page
|
|
import Web.Hyperbole.Route
|
|
|
|
-- Simple MIME type resolver for static files
|
|
mimeType :: FilePath -> BS.ByteString
|
|
mimeType fp
|
|
| ".css" `isSuffixOf` fp = "text/css"
|
|
| ".js" `isSuffixOf` fp = "application/javascript"
|
|
| ".json" `isSuffixOf` fp = "application/json"
|
|
| ".png" `isSuffixOf` fp = "image/png"
|
|
| ".svg" `isSuffixOf` fp = "image/svg+xml"
|
|
| otherwise = "application/octet-stream"
|
|
|
|
main :: IO ()
|
|
main = do
|
|
let dbPath = "data/sis.db"
|
|
createDirectoryIfMissing True (takeDirectory dbPath)
|
|
|
|
putStrLn "[sis] opening database..."
|
|
conn <- openDatabase dbPath
|
|
|
|
let port = 8080
|
|
putStrLn $ "[sis] listening on 0.0.0.0:" <> show port
|
|
|
|
let hyperboleApp =
|
|
liveAppWith
|
|
( ServerOptions
|
|
{ toDocument = document documentHead
|
|
, serverError = defaultError
|
|
, parseRequestBody = defaultParseRequestBodyOptions
|
|
}
|
|
)
|
|
(runDB conn $ routeRequest router)
|
|
|
|
-- Serve static files under /static/, fall through to Hyperbole app
|
|
let staticDir = "frontend/static"
|
|
Warp.run port $ \req respond -> do
|
|
let rawPath = Wai.rawPathInfo req
|
|
if "/static/" `BS.isPrefixOf` rawPath
|
|
then do
|
|
let relPath = C8.unpack (C8.drop (C8.length "/static") rawPath)
|
|
filePath = staticDir ++ relPath
|
|
exists <- doesFileExist filePath
|
|
if exists
|
|
then do
|
|
content <- BS.readFile filePath
|
|
let ct = mimeType filePath
|
|
respond $ Wai.responseLBS HTTP.status200 [("Content-Type", ct)] (BL.fromStrict content)
|
|
else respond $ Wai.responseLBS HTTP.status404 [] "File not found"
|
|
else hyperboleApp req respond
|
|
|
|
router :: (Hyperbole :> es, DB :> es, IOE :> es) => AppRoute -> Eff es Response
|
|
router Home = do
|
|
redirect (routeUri RDashboard)
|
|
router RLogin = runPage Sis.Page.Login.page
|
|
router RSignup = runPage Sis.Page.Signup.page
|
|
router RDashboard = runPage Sis.Page.Dashboard.page
|
|
router RChores = runPage Sis.Page.Chores.page
|
|
router RHousehold = runPage Sis.Page.Household.page
|
|
router RActivity = runPage Sis.Page.Activity.page
|
|
router RSeed = do
|
|
seed
|
|
redirect (routeUri RDashboard)
|