jbrechtel/sis
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix: add static file serving with custom middleware

Browse Source 
- Replaced wai-app-static with lightweight inline static file server
- Static files served from frontend/static/ under /static/ path
- Fixed ByteString/FilePath type mismatches for GHC 9.10
- Verified: CSS, manifest, login, signup, dashboard all HTTP 200
This commit is contained in:
James Brechtel
2026-07-16 07:00:41 -04:00
parent df9ad3d7c4
commit a99c239852
10 changed files with 290 additions and 165 deletions
Download Patch File Download Diff File Expand all files Collapse all files
app/Main.hs
+39 -6
View File
@@ -1,15 +1,20 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-unused-imports -Wno-missing-export-lists #-}
{-# OPTIONS_GHC -Wno-unused-imports -Wno-missing-export-lists -Wno-name-shadowing #-}
module Main where
import Data.ByteString.Char8 qualified as C8
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BL
import Effectful
import Network.Wai.Application.Static qualified as Static
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)
import System.Directory (createDirectoryIfMissing, doesFileExist)
import System.FilePath (takeDirectory)
import Data.List (isSuffixOf)
import Sis.Database
import Sis.Page.Activity
@@ -26,6 +31,16 @@ 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"
@@ -37,14 +52,32 @@ main = do
let port = 8080
putStrLn $ "[sis] listening on 0.0.0.0:" <> show port
let app = liveAppWith
let hyperboleApp =
liveAppWith
( ServerOptions
{ toDocument = document documentHead
, serverError = defaultError
, parseRequestBody = defaultParseRequestBodyOptions
})
}
)
(runDB conn $ routeRequest router)
Warp.run port $ app
-- 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
src/Sis/Database.hs
+114 -84
View File
@@ -5,35 +5,34 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{- | SQLite database support for Sis using the effectful effect system.
-}
module Sis.Database
( -- * Effect
DB (..)
, runDB
, openDatabase
, runMigrations
-- | SQLite database support for Sis using the effectful effect system.
module Sis.Database (
-- * Effect
DB (..),
runDB,
openDatabase,
runMigrations,
-- * DB operations (convenience wrappers)
, findUserByEmail
, createUser
, getUser
, getUserHouseholds
, getHousehold
, createHousehold
, getMembers
, getChores
, createChore
, updateChore
, deleteChore
, getDashboard
, recordActivity
, getActivityLog
, createInvite
, getInvites
, revokeInvite
, acceptInvite
, seed
findUserByEmail,
createUser,
getUser,
getUserHouseholds,
getHousehold,
createHousehold,
getMembers,
getChores,
createChore,
updateChore,
deleteChore,
getDashboard,
recordActivity,
getActivityLog,
createInvite,
getInvites,
revokeInvite,
acceptInvite,
seed,
) where
import Control.Monad (when)
@@ -43,13 +42,13 @@ import Data.Text qualified as T
import Data.Time (Day, UTCTime, addDays, getCurrentTime, utctDay)
import Data.Time qualified as Time
import Data.Time.Calendar (addGregorianMonthsClip)
import Database.SQLite.Simple qualified as SQL
import Database.SQLite.Simple (Only (..))
import Text.Read (readMaybe)
import Database.SQLite.Simple qualified as SQL
import Effectful
import Effectful.Dispatch.Dynamic
import System.Directory (createDirectoryIfMissing)
import System.FilePath (takeDirectory)
import Text.Read (readMaybe)
import Sis.Types
@@ -88,64 +87,76 @@ type instance DispatchOf DB = 'Dynamic
runDB :: (IOE :> es) => SQL.Connection -> Eff (DB : es) a -> Eff es a
runDB conn = interpret $ \_ -> \case
FindUserByEmail email -> liftIO $ do
result <- SQL.query conn
result <-
SQL.query
conn
"SELECT id, display_name, email, password_hash FROM users WHERE email = ?"
(Only email)
pure $ listToMaybe [User (UserId uid) dname em pwHash | (uid, dname, em, pwHash) <- result]
CreateUser dname email pwHash -> liftIO $ do
SQL.execute conn
SQL.execute
conn
"INSERT INTO users (display_name, email, password_hash) VALUES (?, ?, ?)"
(dname, email, pwHash)
uid <- SQL.lastInsertRowId conn
pure $ UserId (fromIntegral uid)
GetUser (UserId uid) -> liftIO $ do
result <- SQL.query conn
result <-
SQL.query
conn
"SELECT id, display_name, email, password_hash FROM users WHERE id = ?"
(Only uid)
pure $ listToMaybe [User (UserId uid') dname em pwHash | (uid', dname, em, pwHash) <- result]
GetUserHouseholds (UserId uid) -> liftIO $ do
rows <- SQL.query conn
rows <-
SQL.query
conn
"SELECT h.id, h.name, m2.user_id, \
\ (SELECT COUNT(*) FROM memberships WHERE household_id = h.id) \
\ FROM households h JOIN memberships m ON m.household_id = h.id AND m.user_id = ? \
\ JOIN memberships m2 ON m2.household_id = h.id AND m2.role = 'owner'"
(Only uid)
pure [Household (HouseholdId hId) hName (UserId ownerId) count | (hId, hName, ownerId, count) <- rows]
GetHousehold (UserId uid) hid -> liftIO $ do
result <- SQL.query conn
result <-
SQL.query
conn
"SELECT h.id, h.name, m2.user_id, (SELECT COUNT(*) FROM memberships WHERE household_id = h.id) \
\ FROM households h JOIN memberships m ON m.household_id = h.id AND m.user_id = ? \
\ JOIN memberships m2 ON m2.household_id = h.id AND m2.role = 'owner' WHERE h.id = ?"
(uid, hid)
pure $ listToMaybe [Household (HouseholdId hId) hName (UserId ownerId) count | (hId, hName, ownerId, count) <- result]
CreateHousehold (UserId uid) name -> liftIO $ do
SQL.execute conn "INSERT INTO households (name) VALUES (?)" (Only name)
hId <- SQL.lastInsertRowId conn
let hid = HouseholdId (fromIntegral hId)
SQL.execute conn
SQL.execute
conn
"INSERT INTO memberships (household_id, user_id, role) VALUES (?, ?, ?)"
(unHouseholdId hid, uid, "owner" :: String)
pure $ Household hid name (UserId uid) 1
GetMembers hid -> liftIO $ do
members <- SQL.query conn
members <-
SQL.query
conn
"SELECT u.id, u.display_name, u.email, m.role \
\ FROM memberships m JOIN users u ON u.id = m.user_id WHERE m.household_id = ?"
(Only hid)
pure [Membership (UserId uid) dname email (if role == ("owner" :: String) then OwnerRole else MemberRole)
| (uid, dname, email, role) <- members]
pure
[ Membership (UserId uid) dname email (if role == ("owner" :: String) then OwnerRole else MemberRole)
| (uid, dname, email, role) <- members
]
GetChores hid -> liftIO $ do
chores <- SQL.query conn
chores <-
SQL.query
conn
"SELECT id, household_id, name, assignee_type, assignee_user_id, schedule_data, notify_on_due, created_at \
\ FROM chores WHERE household_id = ?"
(Only hid) :: IO [(Int, Int, Text, String, Maybe Int, Text, Int, UTCTime)]
pure [Chore { choreId = ChoreId cid
(Only hid) ::
IO [(Int, Int, Text, String, Maybe Int, Text, Int, UTCTime)]
pure
[ Chore
{ choreId = ChoreId cid
, choreHouseholdId = HouseholdId hId
, choreName = cname
, choreAssignee = mkAssignee atype auid
@@ -153,18 +164,19 @@ runDB conn = interpret $ \_ -> \case
, choreNotifyOnDue = nud /= 0
, choreCreatedAt = createdAt
}
| (cid, hId, cname, atype, auid, sData, nud, createdAt) <- chores]
| (cid, hId, cname, atype, auid, sData, nud, createdAt) <- chores
]
where
mkAssignee "user" (Just uid) = AssigneeUser (UserId uid)
mkAssignee _ _ = AssigneeAnyone
mkSchedule sData = fromMaybe ScheduleSometime (readMaybe (T.unpack sData))
CreateChore hid name assignee schedule notify -> liftIO $ do
now <- Time.getCurrentTime
let (aType, aUid) = case assignee of AssigneeUser (UserId uid) -> ("user" :: String, Just uid); AssigneeAnyone -> ("anyone", Nothing)
sType = case schedule of ScheduleOneOff{} -> "one_off" :: String; ScheduleRecurring{} -> "recurring"; ScheduleSometime -> "sometime"
sData = show schedule
SQL.execute conn
SQL.execute
conn
"INSERT INTO chores (household_id, name, assignee_type, assignee_user_id, schedule_type, schedule_data, notify_on_due, created_at) \
\ VALUES (?,?,?,?,?,?,?,?)"
(hid, name, aType, aUid, sType, sData, if notify then 1 :: Int else 0, now)
@@ -172,123 +184,142 @@ runDB conn = interpret $ \_ -> \case
let chore = Chore (ChoreId (fromIntegral cId)) (HouseholdId hid) name assignee schedule notify now
generateOccurrencesIO conn chore
pure chore
UpdateChore cid hid name assignee schedule notify -> liftIO $ do
now <- Time.getCurrentTime
let (aType, aUid) = case assignee of AssigneeUser (UserId uid) -> ("user" :: String, Just uid); AssigneeAnyone -> ("anyone", Nothing)
sType = case schedule of ScheduleOneOff{} -> "one_off" :: String; ScheduleRecurring{} -> "recurring"; ScheduleSometime -> "sometime"
sData = show schedule
SQL.execute conn
SQL.execute
conn
"UPDATE chores SET name=?, assignee_type=?, assignee_user_id=?, schedule_type=?, schedule_data=?, notify_on_due=? WHERE id=? AND household_id=?"
(name, aType, aUid, sType, sData, if notify then 1 :: Int else 0, cid, hid)
SQL.execute conn "DELETE FROM occurrences WHERE chore_id = ? AND status IN ('due', 'overdue')" (Only cid)
let chore = Chore (ChoreId cid) (HouseholdId hid) name assignee schedule notify now
generateOccurrencesIO conn chore
pure chore
DeleteChore cid -> liftIO $ do
SQL.execute conn "DELETE FROM chores WHERE id = ?" (Only cid)
GetDashboard hid today -> liftIO $ do
let todayStr = show today
let weekAgo = show (addDays (-7) today)
[Only overdueCount] <- SQL.query conn
[Only overdueCount] <-
SQL.query
conn
"SELECT COUNT(*) FROM occurrences o JOIN chores c ON c.id = o.chore_id \
\ WHERE c.household_id = ? AND o.due_date < ? AND o.status IN ('due', 'overdue')"
(hid, todayStr)
[Only dueTodayCount] <- SQL.query conn
[Only dueTodayCount] <-
SQL.query
conn
"SELECT COUNT(*) FROM occurrences o JOIN chores c ON c.id = o.chore_id \
\ WHERE c.household_id = ? AND o.due_date = ? AND o.status = 'due'"
(hid, todayStr)
[Only doneThisWeek] <- SQL.query conn
[Only doneThisWeek] <-
SQL.query
conn
"SELECT COUNT(*) FROM activities a JOIN occurrences o ON o.id = a.occurrence_id JOIN chores c ON c.id = o.chore_id \
\ WHERE c.household_id = ? AND a.recorded_at >= ?"
(hid, weekAgo)
let stats = DashboardStats overdueCount dueTodayCount doneThisWeek
dueRows <- SQL.query conn
dueRows <-
SQL.query
conn
"SELECT o.id, o.chore_id, o.due_date, o.status, c.name, u.display_name \
\ FROM occurrences o JOIN chores c ON c.id = o.chore_id LEFT JOIN users u ON u.id = c.assignee_user_id \
\ WHERE c.household_id = ? AND o.due_date <= ? AND o.status IN ('due', 'overdue') ORDER BY o.due_date LIMIT 50"
(hid, todayStr) :: IO [(Int, Int, Day, Text, Text, Maybe Text)]
(hid, todayStr) ::
IO [(Int, Int, Day, Text, Text, Maybe Text)]
let dueItems = [DueItem (Occurrence (OccurrenceId oid) (ChoreId cid) d (mkOcc st)) cn uname (d < today) | (oid, cid, d, st, cn, uname) <- dueRows]
compRows <- SQL.query conn
compRows <-
SQL.query
conn
"SELECT a.id, a.occurrence_id, a.user_id, a.status, a.note, a.notify_household, a.recorded_at, u.display_name, c.name \
\ FROM activities a JOIN occurrences o ON o.id = a.occurrence_id JOIN chores c ON c.id = o.chore_id JOIN users u ON u.id = a.user_id \
\ WHERE c.household_id = ? AND a.recorded_at >= ? ORDER BY a.recorded_at DESC LIMIT 50"
(hid, show today) :: IO [(Int, Int, Int, Text, Maybe Text, Int, UTCTime, Text, Text)]
(hid, show today) ::
IO [(Int, Int, Int, Text, Maybe Text, Int, UTCTime, Text, Text)]
let compItems = [CompletedItem (Activity (ActivityId aid) (OccurrenceId oid) (UserId uid) (mkAct st) note (nh /= 0) recAt) uname cn | (aid, oid, uid, st, note, nh, recAt, uname, cn) <- compRows]
pure $ Dashboard stats dueItems compItems
where
mkOcc "due" = OccDue; mkOcc "overdue" = OccOverdue; mkOcc _ = OccCompleted
mkAct "completed" = ActivityCompleted; mkAct _ = ActivitySkipped
GenerateOccurrences chore -> liftIO $ generateOccurrencesIO conn chore
RecordActivity oid (UserId uid) status note notify -> liftIO $ do
now <- Time.getCurrentTime
let actStatus = case status of ActivityCompleted -> "completed" :: String; ActivitySkipped -> "skipped"
SQL.execute conn
SQL.execute
conn
"INSERT INTO activities (occurrence_id, user_id, status, note, notify_household, recorded_at) VALUES (?,?,?,?,?,?)"
(oid, uid, actStatus, note, if notify then 1 :: Int else 0, now)
let occStatus = case status of ActivityCompleted -> "completed" :: String; ActivitySkipped -> "skipped"
SQL.execute conn "UPDATE occurrences SET status = ? WHERE id = ?" (occStatus, oid)
actId <- SQL.lastInsertRowId conn
pure $ Activity (ActivityId (fromIntegral actId)) (OccurrenceId oid) (UserId uid) status note notify now
GetActivityLog hid page perPage -> liftIO $ do
let offset = (page - 1) * perPage
[Only totalCount] <- SQL.query conn
[Only totalCount] <-
SQL.query
conn
"SELECT COUNT(*) FROM activities a JOIN occurrences o ON o.id = a.occurrence_id JOIN chores c ON c.id = o.chore_id WHERE c.household_id = ?"
(Only hid)
entries <- SQL.query conn
entries <-
SQL.query
conn
"SELECT a.id, a.occurrence_id, a.user_id, a.status, a.note, a.notify_household, a.recorded_at, u.display_name, c.name, o.due_date \
\ FROM activities a JOIN occurrences o ON o.id = a.occurrence_id JOIN chores c ON c.id = o.chore_id JOIN users u ON u.id = a.user_id \
\ WHERE c.household_id = ? ORDER BY a.recorded_at DESC LIMIT ? OFFSET ?"
(hid, perPage, offset) :: IO [(Int, Int, Int, Text, Maybe Text, Int, UTCTime, Text, Text, Day)]
(hid, perPage, offset) ::
IO [(Int, Int, Int, Text, Maybe Text, Int, UTCTime, Text, Text, Day)]
let logEntries = [ActivityLogEntry (Activity (ActivityId aid) (OccurrenceId oid) (UserId uid) (mkAct st) note (nh /= 0) recAt) uname "" cn d | (aid, oid, uid, st, note, nh, recAt, uname, cn, d) <- entries]
pure $ ActivityLogPage logEntries page perPage totalCount
where
mkAct "completed" = ActivityCompleted; mkAct _ = ActivitySkipped
CreateInvite hid email -> liftIO $ do
code <- generateTokenIO
now <- Time.getCurrentTime
SQL.execute conn
SQL.execute
conn
"INSERT INTO invites (household_id, code, email, created_at) VALUES (?, ?, ?, ?)"
(hid, code, email, now)
iid <- SQL.lastInsertRowId conn
pure $ Invite (InviteId (fromIntegral iid)) (HouseholdId hid) code email InvitePending now
GetInvites hid -> liftIO $ do
invites <- SQL.query conn
invites <-
SQL.query
conn
"SELECT id, household_id, code, email, status, created_at FROM invites WHERE household_id = ?"
(Only hid) :: IO [(Int, Int, Text, Maybe Text, Text, UTCTime)]
(Only hid) ::
IO [(Int, Int, Text, Maybe Text, Text, UTCTime)]
pure [Invite (InviteId iid) (HouseholdId hhid) code email (mkStatus st) createdAt | (iid, hhid, code, email, st, createdAt) <- invites]
where
mkStatus "pending" = InvitePending; mkStatus "accepted" = InviteAccepted; mkStatus _ = InviteRevoked
RevokeInvite iid -> liftIO $ do
SQL.execute conn "UPDATE invites SET status = 'revoked' WHERE id = ?" (Only iid)
AcceptInvite (UserId uid) code -> liftIO $ do
result <- SQL.query conn
result <-
SQL.query
conn
"SELECT id, household_id FROM invites WHERE code = ? AND status = 'pending'"
(Only code) :: IO [(Int, Int)]
(Only code) ::
IO [(Int, Int)]
case result of
[(_, hid)] -> do
SQL.execute conn
SQL.execute
conn
"INSERT OR IGNORE INTO memberships (household_id, user_id, role) VALUES (?, ?, ?)"
(hid, uid, "member" :: String)
SQL.execute conn "UPDATE invites SET status = 'accepted' WHERE code = ?" (Only code)
hResult <- SQL.query conn
hResult <-
SQL.query
conn
"SELECT h.id, h.name, m.user_id, (SELECT COUNT(*) FROM memberships WHERE household_id = h.id) \
\ FROM households h JOIN memberships m ON m.household_id = h.id AND m.role = 'owner' WHERE h.id = ?"
(Only hid) :: IO [(Int, Text, Int, Int)]
(Only hid) ::
IO [(Int, Text, Int, Int)]
case listToMaybe [Household (HouseholdId hId) hName (UserId ownerId) count | (hId, hName, ownerId, count) <- hResult] of
Just h -> pure h
Nothing -> error "Household not found after accept"
_ -> error "Invite not found"
Seed -> liftIO $ do
let demoPassword = "password123"
pwHash <- hashPasswordIO demoPassword
@@ -351,8 +382,7 @@ generateTokenIO = do
-- Database open helper
----------------------------------------------------------------------
{- | Open (or create) a SQLite database at the given path.
-}
-- | Open (or create) a SQLite database at the given path.
openDatabase :: FilePath -> IO SQL.Connection
openDatabase path = do
createDirectoryIfMissing True (takeDirectory path)
src/Sis/Page/Activity.hs
+9 -1
View File
@@ -1,5 +1,13 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-unused-imports -Wno-unused-do-bind -Wno-name-shadowing -Wno-redundant-constraints -Wno-redundant-constraints #-}
{-# LANGUAGE FlexibleContexts, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, TypeApplications, TypeOperators, OverloadedStrings #-}
module Sis.Page.Activity (page) where
src/Sis/Page/Chores.hs
+9 -1
View File
@@ -1,5 +1,13 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-unused-imports -Wno-unused-do-bind -Wno-name-shadowing -Wno-redundant-constraints -Wno-redundant-constraints #-}
{-# LANGUAGE FlexibleContexts, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, TypeApplications, TypeOperators, OverloadedStrings #-}
module Sis.Page.Chores (page) where
src/Sis/Page/Dashboard.hs
+9 -1
View File
@@ -1,5 +1,13 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-unused-imports -Wno-unused-do-bind -Wno-name-shadowing #-}
{-# LANGUAGE FlexibleContexts, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, TypeApplications, TypeOperators, OverloadedStrings #-}
module Sis.Page.Dashboard (page) where
src/Sis/Page/Household.hs
+9 -1
View File
@@ -1,5 +1,13 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-unused-imports -Wno-unused-do-bind -Wno-name-shadowing -Wno-redundant-constraints #-}
{-# LANGUAGE FlexibleContexts, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, TypeApplications, TypeOperators, OverloadedStrings #-}
module Sis.Page.Household (page) where
src/Sis/Page/Login.hs
+13 -3
View File
@@ -1,12 +1,21 @@
{-# LANGUAGE FlexibleContexts, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, TypeApplications, TypeOperators, OverloadedStrings #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-unused-imports -Wno-unused-do-bind -Wno-redundant-constraints #-}
module Sis.Page.Login (page) where
import Effectful
import Data.Text (Text)
import Data.Text qualified as T
import Effectful
import Sis.Auth (generateToken, hashPassword, verifyPassword)
import Sis.Database
import Sis.Auth (hashPassword, verifyPassword, generateToken)
import Sis.Route
import Sis.Style
import Sis.Types
@@ -15,6 +24,7 @@ import Web.Hyperbole
import Web.Hyperbole.Effect.Session
import Web.Hyperbole.HyperView.Forms
import Web.Hyperbole.Page
data LoginPage = LoginPage
deriving stock (Generic)
deriving anyclass (ViewId)
src/Sis/Page/Signup.hs
+13 -3
View File
@@ -1,13 +1,22 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# LANGUAGE FlexibleContexts, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, TypeApplications, TypeOperators, OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-unused-imports -Wno-unused-do-bind -Wno-redundant-constraints #-}
module Sis.Page.Signup (page) where
import Effectful
import Data.Text (Text)
import Data.Text qualified as T
import Effectful
import Sis.Auth (generateToken, hashPassword, verifyPassword)
import Sis.Database
import Sis.Auth (hashPassword, verifyPassword, generateToken)
import Sis.Route
import Sis.Style
import Sis.Types
@@ -16,6 +25,7 @@ import Web.Hyperbole
import Web.Hyperbole.Effect.Session
import Web.Hyperbole.HyperView.Forms
import Web.Hyperbole.Page
data SignupPage = SignupPage
deriving stock (Generic)
deriving anyclass (ViewId)
src/Sis/Style.hs
+17 -7
View File
@@ -1,12 +1,22 @@
{-# LANGUAGE OverloadedStrings #-}
-- | Neo Brutalism CSS class name constants for Hyperbole views.
-- Use with: \@ att \"class\" nbBoxClass
module Sis.Style
( nbBoxClass, nbButtonClass, nbInputClass, nbLabelClass
, nbBadgeClass, nbFontHeading1Class, nbFontHeading2Class
, nbNavbarClass, nbContainerClass, nbListItemClass
, colorRed, colorYellow, colorGreen
{- | Neo Brutalism CSS class name constants for Hyperbole views.
Use with: \@ att \"class\" nbBoxClass
-}
module Sis.Style (
nbBoxClass,
nbButtonClass,
nbInputClass,
nbLabelClass,
nbBadgeClass,
nbFontHeading1Class,
nbFontHeading2Class,
nbNavbarClass,
nbContainerClass,
nbListItemClass,
colorRed,
colorYellow,
colorGreen,
) where
import Data.Text (Text)
src/Sis/View/Layout.hs
+4 -4
View File
@@ -3,10 +3,10 @@
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-unused-imports #-}
module Sis.View.Layout
( documentHead
, navbar
, UserSession (..)
module Sis.View.Layout (
documentHead,
navbar,
UserSession (..),
) where
import Data.Aeson