fix: add static file serving with custom middleware
- 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:
+40
-7
@@ -1,15 +1,20 @@
|
|||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# 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
|
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 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 Network.Wai.Handler.Warp qualified as Warp
|
||||||
import System.Directory (createDirectoryIfMissing)
|
import System.Directory (createDirectoryIfMissing, doesFileExist)
|
||||||
import System.FilePath (takeDirectory)
|
import System.FilePath (takeDirectory)
|
||||||
|
import Data.List (isSuffixOf)
|
||||||
|
|
||||||
import Sis.Database
|
import Sis.Database
|
||||||
import Sis.Page.Activity
|
import Sis.Page.Activity
|
||||||
@@ -26,6 +31,16 @@ import Web.Hyperbole.Effect.Response
|
|||||||
import Web.Hyperbole.Page
|
import Web.Hyperbole.Page
|
||||||
import Web.Hyperbole.Route
|
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 :: IO ()
|
||||||
main = do
|
main = do
|
||||||
let dbPath = "data/sis.db"
|
let dbPath = "data/sis.db"
|
||||||
@@ -37,14 +52,32 @@ main = do
|
|||||||
let port = 8080
|
let port = 8080
|
||||||
putStrLn $ "[sis] listening on 0.0.0.0:" <> show port
|
putStrLn $ "[sis] listening on 0.0.0.0:" <> show port
|
||||||
|
|
||||||
let app = liveAppWith
|
let hyperboleApp =
|
||||||
(ServerOptions
|
liveAppWith
|
||||||
|
( ServerOptions
|
||||||
{ toDocument = document documentHead
|
{ toDocument = document documentHead
|
||||||
, serverError = defaultError
|
, serverError = defaultError
|
||||||
, parseRequestBody = defaultParseRequestBodyOptions
|
, parseRequestBody = defaultParseRequestBodyOptions
|
||||||
})
|
}
|
||||||
|
)
|
||||||
(runDB conn $ routeRequest router)
|
(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 :: (Hyperbole :> es, DB :> es, IOE :> es) => AppRoute -> Eff es Response
|
||||||
router Home = do
|
router Home = do
|
||||||
|
|||||||
+115
-85
@@ -5,36 +5,35 @@
|
|||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
|
||||||
{- | SQLite database support for Sis using the effectful effect system.
|
-- | SQLite database support for Sis using the effectful effect system.
|
||||||
-}
|
module Sis.Database (
|
||||||
module Sis.Database
|
-- * Effect
|
||||||
( -- * Effect
|
DB (..),
|
||||||
DB (..)
|
runDB,
|
||||||
, runDB
|
openDatabase,
|
||||||
, openDatabase
|
runMigrations,
|
||||||
, runMigrations
|
|
||||||
|
|
||||||
-- * DB operations (convenience wrappers)
|
-- * DB operations (convenience wrappers)
|
||||||
, findUserByEmail
|
findUserByEmail,
|
||||||
, createUser
|
createUser,
|
||||||
, getUser
|
getUser,
|
||||||
, getUserHouseholds
|
getUserHouseholds,
|
||||||
, getHousehold
|
getHousehold,
|
||||||
, createHousehold
|
createHousehold,
|
||||||
, getMembers
|
getMembers,
|
||||||
, getChores
|
getChores,
|
||||||
, createChore
|
createChore,
|
||||||
, updateChore
|
updateChore,
|
||||||
, deleteChore
|
deleteChore,
|
||||||
, getDashboard
|
getDashboard,
|
||||||
, recordActivity
|
recordActivity,
|
||||||
, getActivityLog
|
getActivityLog,
|
||||||
, createInvite
|
createInvite,
|
||||||
, getInvites
|
getInvites,
|
||||||
, revokeInvite
|
revokeInvite,
|
||||||
, acceptInvite
|
acceptInvite,
|
||||||
, seed
|
seed,
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Monad (when)
|
import Control.Monad (when)
|
||||||
import Data.Maybe (fromMaybe, listToMaybe)
|
import Data.Maybe (fromMaybe, listToMaybe)
|
||||||
@@ -43,13 +42,13 @@ import Data.Text qualified as T
|
|||||||
import Data.Time (Day, UTCTime, addDays, getCurrentTime, utctDay)
|
import Data.Time (Day, UTCTime, addDays, getCurrentTime, utctDay)
|
||||||
import Data.Time qualified as Time
|
import Data.Time qualified as Time
|
||||||
import Data.Time.Calendar (addGregorianMonthsClip)
|
import Data.Time.Calendar (addGregorianMonthsClip)
|
||||||
import Database.SQLite.Simple qualified as SQL
|
|
||||||
import Database.SQLite.Simple (Only (..))
|
import Database.SQLite.Simple (Only (..))
|
||||||
import Text.Read (readMaybe)
|
import Database.SQLite.Simple qualified as SQL
|
||||||
import Effectful
|
import Effectful
|
||||||
import Effectful.Dispatch.Dynamic
|
import Effectful.Dispatch.Dynamic
|
||||||
import System.Directory (createDirectoryIfMissing)
|
import System.Directory (createDirectoryIfMissing)
|
||||||
import System.FilePath (takeDirectory)
|
import System.FilePath (takeDirectory)
|
||||||
|
import Text.Read (readMaybe)
|
||||||
|
|
||||||
import Sis.Types
|
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 :: (IOE :> es) => SQL.Connection -> Eff (DB : es) a -> Eff es a
|
||||||
runDB conn = interpret $ \_ -> \case
|
runDB conn = interpret $ \_ -> \case
|
||||||
FindUserByEmail email -> liftIO $ do
|
FindUserByEmail email -> liftIO $ do
|
||||||
result <- SQL.query conn
|
result <-
|
||||||
|
SQL.query
|
||||||
|
conn
|
||||||
"SELECT id, display_name, email, password_hash FROM users WHERE email = ?"
|
"SELECT id, display_name, email, password_hash FROM users WHERE email = ?"
|
||||||
(Only email)
|
(Only email)
|
||||||
pure $ listToMaybe [User (UserId uid) dname em pwHash | (uid, dname, em, pwHash) <- result]
|
pure $ listToMaybe [User (UserId uid) dname em pwHash | (uid, dname, em, pwHash) <- result]
|
||||||
|
|
||||||
CreateUser dname email pwHash -> liftIO $ do
|
CreateUser dname email pwHash -> liftIO $ do
|
||||||
SQL.execute conn
|
SQL.execute
|
||||||
|
conn
|
||||||
"INSERT INTO users (display_name, email, password_hash) VALUES (?, ?, ?)"
|
"INSERT INTO users (display_name, email, password_hash) VALUES (?, ?, ?)"
|
||||||
(dname, email, pwHash)
|
(dname, email, pwHash)
|
||||||
uid <- SQL.lastInsertRowId conn
|
uid <- SQL.lastInsertRowId conn
|
||||||
pure $ UserId (fromIntegral uid)
|
pure $ UserId (fromIntegral uid)
|
||||||
|
|
||||||
GetUser (UserId uid) -> liftIO $ do
|
GetUser (UserId uid) -> liftIO $ do
|
||||||
result <- SQL.query conn
|
result <-
|
||||||
|
SQL.query
|
||||||
|
conn
|
||||||
"SELECT id, display_name, email, password_hash FROM users WHERE id = ?"
|
"SELECT id, display_name, email, password_hash FROM users WHERE id = ?"
|
||||||
(Only uid)
|
(Only uid)
|
||||||
pure $ listToMaybe [User (UserId uid') dname em pwHash | (uid', dname, em, pwHash) <- result]
|
pure $ listToMaybe [User (UserId uid') dname em pwHash | (uid', dname, em, pwHash) <- result]
|
||||||
|
|
||||||
GetUserHouseholds (UserId uid) -> liftIO $ do
|
GetUserHouseholds (UserId uid) -> liftIO $ do
|
||||||
rows <- SQL.query conn
|
rows <-
|
||||||
|
SQL.query
|
||||||
|
conn
|
||||||
"SELECT h.id, h.name, m2.user_id, \
|
"SELECT h.id, h.name, m2.user_id, \
|
||||||
\ (SELECT COUNT(*) FROM memberships WHERE household_id = h.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 = ? \
|
\ 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'"
|
\ JOIN memberships m2 ON m2.household_id = h.id AND m2.role = 'owner'"
|
||||||
(Only uid)
|
(Only uid)
|
||||||
pure [Household (HouseholdId hId) hName (UserId ownerId) count | (hId, hName, ownerId, count) <- rows]
|
pure [Household (HouseholdId hId) hName (UserId ownerId) count | (hId, hName, ownerId, count) <- rows]
|
||||||
|
|
||||||
GetHousehold (UserId uid) hid -> liftIO $ do
|
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) \
|
"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 = ? \
|
\ 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 = ?"
|
\ JOIN memberships m2 ON m2.household_id = h.id AND m2.role = 'owner' WHERE h.id = ?"
|
||||||
(uid, hid)
|
(uid, hid)
|
||||||
pure $ listToMaybe [Household (HouseholdId hId) hName (UserId ownerId) count | (hId, hName, ownerId, count) <- result]
|
pure $ listToMaybe [Household (HouseholdId hId) hName (UserId ownerId) count | (hId, hName, ownerId, count) <- result]
|
||||||
|
|
||||||
CreateHousehold (UserId uid) name -> liftIO $ do
|
CreateHousehold (UserId uid) name -> liftIO $ do
|
||||||
SQL.execute conn "INSERT INTO households (name) VALUES (?)" (Only name)
|
SQL.execute conn "INSERT INTO households (name) VALUES (?)" (Only name)
|
||||||
hId <- SQL.lastInsertRowId conn
|
hId <- SQL.lastInsertRowId conn
|
||||||
let hid = HouseholdId (fromIntegral hId)
|
let hid = HouseholdId (fromIntegral hId)
|
||||||
SQL.execute conn
|
SQL.execute
|
||||||
|
conn
|
||||||
"INSERT INTO memberships (household_id, user_id, role) VALUES (?, ?, ?)"
|
"INSERT INTO memberships (household_id, user_id, role) VALUES (?, ?, ?)"
|
||||||
(unHouseholdId hid, uid, "owner" :: String)
|
(unHouseholdId hid, uid, "owner" :: String)
|
||||||
pure $ Household hid name (UserId uid) 1
|
pure $ Household hid name (UserId uid) 1
|
||||||
|
|
||||||
GetMembers hid -> liftIO $ do
|
GetMembers hid -> liftIO $ do
|
||||||
members <- SQL.query conn
|
members <-
|
||||||
|
SQL.query
|
||||||
|
conn
|
||||||
"SELECT u.id, u.display_name, u.email, m.role \
|
"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 = ?"
|
\ FROM memberships m JOIN users u ON u.id = m.user_id WHERE m.household_id = ?"
|
||||||
(Only hid)
|
(Only hid)
|
||||||
pure [Membership (UserId uid) dname email (if role == ("owner" :: String) then OwnerRole else MemberRole)
|
pure
|
||||||
| (uid, dname, email, role) <- members]
|
[ Membership (UserId uid) dname email (if role == ("owner" :: String) then OwnerRole else MemberRole)
|
||||||
|
| (uid, dname, email, role) <- members
|
||||||
|
]
|
||||||
GetChores hid -> liftIO $ do
|
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 \
|
"SELECT id, household_id, name, assignee_type, assignee_user_id, schedule_data, notify_on_due, created_at \
|
||||||
\ FROM chores WHERE household_id = ?"
|
\ FROM chores WHERE household_id = ?"
|
||||||
(Only hid) :: IO [(Int, Int, Text, String, Maybe Int, Text, Int, UTCTime)]
|
(Only hid) ::
|
||||||
pure [Chore { choreId = ChoreId cid
|
IO [(Int, Int, Text, String, Maybe Int, Text, Int, UTCTime)]
|
||||||
|
pure
|
||||||
|
[ Chore
|
||||||
|
{ choreId = ChoreId cid
|
||||||
, choreHouseholdId = HouseholdId hId
|
, choreHouseholdId = HouseholdId hId
|
||||||
, choreName = cname
|
, choreName = cname
|
||||||
, choreAssignee = mkAssignee atype auid
|
, choreAssignee = mkAssignee atype auid
|
||||||
@@ -153,18 +164,19 @@ runDB conn = interpret $ \_ -> \case
|
|||||||
, choreNotifyOnDue = nud /= 0
|
, choreNotifyOnDue = nud /= 0
|
||||||
, choreCreatedAt = createdAt
|
, choreCreatedAt = createdAt
|
||||||
}
|
}
|
||||||
| (cid, hId, cname, atype, auid, sData, nud, createdAt) <- chores]
|
| (cid, hId, cname, atype, auid, sData, nud, createdAt) <- chores
|
||||||
|
]
|
||||||
where
|
where
|
||||||
mkAssignee "user" (Just uid) = AssigneeUser (UserId uid)
|
mkAssignee "user" (Just uid) = AssigneeUser (UserId uid)
|
||||||
mkAssignee _ _ = AssigneeAnyone
|
mkAssignee _ _ = AssigneeAnyone
|
||||||
mkSchedule sData = fromMaybe ScheduleSometime (readMaybe (T.unpack sData))
|
mkSchedule sData = fromMaybe ScheduleSometime (readMaybe (T.unpack sData))
|
||||||
|
|
||||||
CreateChore hid name assignee schedule notify -> liftIO $ do
|
CreateChore hid name assignee schedule notify -> liftIO $ do
|
||||||
now <- Time.getCurrentTime
|
now <- Time.getCurrentTime
|
||||||
let (aType, aUid) = case assignee of AssigneeUser (UserId uid) -> ("user" :: String, Just uid); AssigneeAnyone -> ("anyone", Nothing)
|
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"
|
sType = case schedule of ScheduleOneOff{} -> "one_off" :: String; ScheduleRecurring{} -> "recurring"; ScheduleSometime -> "sometime"
|
||||||
sData = show schedule
|
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) \
|
"INSERT INTO chores (household_id, name, assignee_type, assignee_user_id, schedule_type, schedule_data, notify_on_due, created_at) \
|
||||||
\ VALUES (?,?,?,?,?,?,?,?)"
|
\ VALUES (?,?,?,?,?,?,?,?)"
|
||||||
(hid, name, aType, aUid, sType, sData, if notify then 1 :: Int else 0, now)
|
(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
|
let chore = Chore (ChoreId (fromIntegral cId)) (HouseholdId hid) name assignee schedule notify now
|
||||||
generateOccurrencesIO conn chore
|
generateOccurrencesIO conn chore
|
||||||
pure chore
|
pure chore
|
||||||
|
|
||||||
UpdateChore cid hid name assignee schedule notify -> liftIO $ do
|
UpdateChore cid hid name assignee schedule notify -> liftIO $ do
|
||||||
now <- Time.getCurrentTime
|
now <- Time.getCurrentTime
|
||||||
let (aType, aUid) = case assignee of AssigneeUser (UserId uid) -> ("user" :: String, Just uid); AssigneeAnyone -> ("anyone", Nothing)
|
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"
|
sType = case schedule of ScheduleOneOff{} -> "one_off" :: String; ScheduleRecurring{} -> "recurring"; ScheduleSometime -> "sometime"
|
||||||
sData = show schedule
|
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=?"
|
"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)
|
(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)
|
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
|
let chore = Chore (ChoreId cid) (HouseholdId hid) name assignee schedule notify now
|
||||||
generateOccurrencesIO conn chore
|
generateOccurrencesIO conn chore
|
||||||
pure chore
|
pure chore
|
||||||
|
|
||||||
DeleteChore cid -> liftIO $ do
|
DeleteChore cid -> liftIO $ do
|
||||||
SQL.execute conn "DELETE FROM chores WHERE id = ?" (Only cid)
|
SQL.execute conn "DELETE FROM chores WHERE id = ?" (Only cid)
|
||||||
|
|
||||||
GetDashboard hid today -> liftIO $ do
|
GetDashboard hid today -> liftIO $ do
|
||||||
let todayStr = show today
|
let todayStr = show today
|
||||||
let weekAgo = show (addDays (-7) 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 \
|
"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')"
|
\ WHERE c.household_id = ? AND o.due_date < ? AND o.status IN ('due', 'overdue')"
|
||||||
(hid, todayStr)
|
(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 \
|
"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'"
|
\ WHERE c.household_id = ? AND o.due_date = ? AND o.status = 'due'"
|
||||||
(hid, todayStr)
|
(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 \
|
"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 >= ?"
|
\ WHERE c.household_id = ? AND a.recorded_at >= ?"
|
||||||
(hid, weekAgo)
|
(hid, weekAgo)
|
||||||
let stats = DashboardStats overdueCount dueTodayCount doneThisWeek
|
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 \
|
"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 \
|
\ 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"
|
\ 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]
|
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 \
|
"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 \
|
\ 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"
|
\ 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]
|
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
|
pure $ Dashboard stats dueItems compItems
|
||||||
where
|
where
|
||||||
mkOcc "due" = OccDue; mkOcc "overdue" = OccOverdue; mkOcc _ = OccCompleted
|
mkOcc "due" = OccDue; mkOcc "overdue" = OccOverdue; mkOcc _ = OccCompleted
|
||||||
mkAct "completed" = ActivityCompleted; mkAct _ = ActivitySkipped
|
mkAct "completed" = ActivityCompleted; mkAct _ = ActivitySkipped
|
||||||
|
|
||||||
GenerateOccurrences chore -> liftIO $ generateOccurrencesIO conn chore
|
GenerateOccurrences chore -> liftIO $ generateOccurrencesIO conn chore
|
||||||
|
|
||||||
RecordActivity oid (UserId uid) status note notify -> liftIO $ do
|
RecordActivity oid (UserId uid) status note notify -> liftIO $ do
|
||||||
now <- Time.getCurrentTime
|
now <- Time.getCurrentTime
|
||||||
let actStatus = case status of ActivityCompleted -> "completed" :: String; ActivitySkipped -> "skipped"
|
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 (?,?,?,?,?,?)"
|
"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)
|
(oid, uid, actStatus, note, if notify then 1 :: Int else 0, now)
|
||||||
let occStatus = case status of ActivityCompleted -> "completed" :: String; ActivitySkipped -> "skipped"
|
let occStatus = case status of ActivityCompleted -> "completed" :: String; ActivitySkipped -> "skipped"
|
||||||
SQL.execute conn "UPDATE occurrences SET status = ? WHERE id = ?" (occStatus, oid)
|
SQL.execute conn "UPDATE occurrences SET status = ? WHERE id = ?" (occStatus, oid)
|
||||||
actId <- SQL.lastInsertRowId conn
|
actId <- SQL.lastInsertRowId conn
|
||||||
pure $ Activity (ActivityId (fromIntegral actId)) (OccurrenceId oid) (UserId uid) status note notify now
|
pure $ Activity (ActivityId (fromIntegral actId)) (OccurrenceId oid) (UserId uid) status note notify now
|
||||||
|
|
||||||
GetActivityLog hid page perPage -> liftIO $ do
|
GetActivityLog hid page perPage -> liftIO $ do
|
||||||
let offset = (page - 1) * perPage
|
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 = ?"
|
"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)
|
(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 \
|
"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 \
|
\ 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 ?"
|
\ 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]
|
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
|
pure $ ActivityLogPage logEntries page perPage totalCount
|
||||||
where
|
where
|
||||||
mkAct "completed" = ActivityCompleted; mkAct _ = ActivitySkipped
|
mkAct "completed" = ActivityCompleted; mkAct _ = ActivitySkipped
|
||||||
|
|
||||||
CreateInvite hid email -> liftIO $ do
|
CreateInvite hid email -> liftIO $ do
|
||||||
code <- generateTokenIO
|
code <- generateTokenIO
|
||||||
now <- Time.getCurrentTime
|
now <- Time.getCurrentTime
|
||||||
SQL.execute conn
|
SQL.execute
|
||||||
|
conn
|
||||||
"INSERT INTO invites (household_id, code, email, created_at) VALUES (?, ?, ?, ?)"
|
"INSERT INTO invites (household_id, code, email, created_at) VALUES (?, ?, ?, ?)"
|
||||||
(hid, code, email, now)
|
(hid, code, email, now)
|
||||||
iid <- SQL.lastInsertRowId conn
|
iid <- SQL.lastInsertRowId conn
|
||||||
pure $ Invite (InviteId (fromIntegral iid)) (HouseholdId hid) code email InvitePending now
|
pure $ Invite (InviteId (fromIntegral iid)) (HouseholdId hid) code email InvitePending now
|
||||||
|
|
||||||
GetInvites hid -> liftIO $ do
|
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 = ?"
|
"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]
|
pure [Invite (InviteId iid) (HouseholdId hhid) code email (mkStatus st) createdAt | (iid, hhid, code, email, st, createdAt) <- invites]
|
||||||
where
|
where
|
||||||
mkStatus "pending" = InvitePending; mkStatus "accepted" = InviteAccepted; mkStatus _ = InviteRevoked
|
mkStatus "pending" = InvitePending; mkStatus "accepted" = InviteAccepted; mkStatus _ = InviteRevoked
|
||||||
|
|
||||||
RevokeInvite iid -> liftIO $ do
|
RevokeInvite iid -> liftIO $ do
|
||||||
SQL.execute conn "UPDATE invites SET status = 'revoked' WHERE id = ?" (Only iid)
|
SQL.execute conn "UPDATE invites SET status = 'revoked' WHERE id = ?" (Only iid)
|
||||||
|
|
||||||
AcceptInvite (UserId uid) code -> liftIO $ do
|
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'"
|
"SELECT id, household_id FROM invites WHERE code = ? AND status = 'pending'"
|
||||||
(Only code) :: IO [(Int, Int)]
|
(Only code) ::
|
||||||
|
IO [(Int, Int)]
|
||||||
case result of
|
case result of
|
||||||
[(_, hid)] -> do
|
[(_, hid)] -> do
|
||||||
SQL.execute conn
|
SQL.execute
|
||||||
|
conn
|
||||||
"INSERT OR IGNORE INTO memberships (household_id, user_id, role) VALUES (?, ?, ?)"
|
"INSERT OR IGNORE INTO memberships (household_id, user_id, role) VALUES (?, ?, ?)"
|
||||||
(hid, uid, "member" :: String)
|
(hid, uid, "member" :: String)
|
||||||
SQL.execute conn "UPDATE invites SET status = 'accepted' WHERE code = ?" (Only code)
|
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) \
|
"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 = ?"
|
\ 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
|
case listToMaybe [Household (HouseholdId hId) hName (UserId ownerId) count | (hId, hName, ownerId, count) <- hResult] of
|
||||||
Just h -> pure h
|
Just h -> pure h
|
||||||
Nothing -> error "Household not found after accept"
|
Nothing -> error "Household not found after accept"
|
||||||
_ -> error "Invite not found"
|
_ -> error "Invite not found"
|
||||||
|
|
||||||
Seed -> liftIO $ do
|
Seed -> liftIO $ do
|
||||||
let demoPassword = "password123"
|
let demoPassword = "password123"
|
||||||
pwHash <- hashPasswordIO demoPassword
|
pwHash <- hashPasswordIO demoPassword
|
||||||
@@ -351,8 +382,7 @@ generateTokenIO = do
|
|||||||
-- Database open helper
|
-- 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 :: FilePath -> IO SQL.Connection
|
||||||
openDatabase path = do
|
openDatabase path = do
|
||||||
createDirectoryIfMissing True (takeDirectory path)
|
createDirectoryIfMissing True (takeDirectory path)
|
||||||
|
|||||||
@@ -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 #-}
|
{-# 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
|
module Sis.Page.Activity (page) where
|
||||||
|
|
||||||
|
|||||||
@@ -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 #-}
|
{-# 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
|
module Sis.Page.Chores (page) where
|
||||||
|
|
||||||
|
|||||||
@@ -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 #-}
|
{-# 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
|
module Sis.Page.Dashboard (page) where
|
||||||
|
|
||||||
|
|||||||
@@ -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 #-}
|
{-# 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
|
module Sis.Page.Household (page) where
|
||||||
|
|
||||||
|
|||||||
+13
-3
@@ -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 #-}
|
{-# OPTIONS_GHC -Wno-unused-imports -Wno-unused-do-bind -Wno-redundant-constraints #-}
|
||||||
|
|
||||||
module Sis.Page.Login (page) where
|
module Sis.Page.Login (page) where
|
||||||
import Effectful
|
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Text qualified as T
|
import Data.Text qualified as T
|
||||||
|
import Effectful
|
||||||
|
import Sis.Auth (generateToken, hashPassword, verifyPassword)
|
||||||
import Sis.Database
|
import Sis.Database
|
||||||
import Sis.Auth (hashPassword, verifyPassword, generateToken)
|
|
||||||
import Sis.Route
|
import Sis.Route
|
||||||
import Sis.Style
|
import Sis.Style
|
||||||
import Sis.Types
|
import Sis.Types
|
||||||
@@ -15,6 +24,7 @@ import Web.Hyperbole
|
|||||||
import Web.Hyperbole.Effect.Session
|
import Web.Hyperbole.Effect.Session
|
||||||
import Web.Hyperbole.HyperView.Forms
|
import Web.Hyperbole.HyperView.Forms
|
||||||
import Web.Hyperbole.Page
|
import Web.Hyperbole.Page
|
||||||
|
|
||||||
data LoginPage = LoginPage
|
data LoginPage = LoginPage
|
||||||
deriving stock (Generic)
|
deriving stock (Generic)
|
||||||
deriving anyclass (ViewId)
|
deriving anyclass (ViewId)
|
||||||
|
|||||||
+13
-3
@@ -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 #-}
|
{-# 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 #-}
|
{-# OPTIONS_GHC -Wno-unused-imports -Wno-unused-do-bind -Wno-redundant-constraints #-}
|
||||||
|
|
||||||
module Sis.Page.Signup (page) where
|
module Sis.Page.Signup (page) where
|
||||||
import Effectful
|
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Text qualified as T
|
import Data.Text qualified as T
|
||||||
|
import Effectful
|
||||||
|
import Sis.Auth (generateToken, hashPassword, verifyPassword)
|
||||||
import Sis.Database
|
import Sis.Database
|
||||||
import Sis.Auth (hashPassword, verifyPassword, generateToken)
|
|
||||||
import Sis.Route
|
import Sis.Route
|
||||||
import Sis.Style
|
import Sis.Style
|
||||||
import Sis.Types
|
import Sis.Types
|
||||||
@@ -16,6 +25,7 @@ import Web.Hyperbole
|
|||||||
import Web.Hyperbole.Effect.Session
|
import Web.Hyperbole.Effect.Session
|
||||||
import Web.Hyperbole.HyperView.Forms
|
import Web.Hyperbole.HyperView.Forms
|
||||||
import Web.Hyperbole.Page
|
import Web.Hyperbole.Page
|
||||||
|
|
||||||
data SignupPage = SignupPage
|
data SignupPage = SignupPage
|
||||||
deriving stock (Generic)
|
deriving stock (Generic)
|
||||||
deriving anyclass (ViewId)
|
deriving anyclass (ViewId)
|
||||||
|
|||||||
+18
-8
@@ -1,13 +1,23 @@
|
|||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
-- | Neo Brutalism CSS class name constants for Hyperbole views.
|
{- | Neo Brutalism CSS class name constants for Hyperbole views.
|
||||||
-- Use with: \@ att \"class\" nbBoxClass
|
Use with: \@ att \"class\" nbBoxClass
|
||||||
module Sis.Style
|
-}
|
||||||
( nbBoxClass, nbButtonClass, nbInputClass, nbLabelClass
|
module Sis.Style (
|
||||||
, nbBadgeClass, nbFontHeading1Class, nbFontHeading2Class
|
nbBoxClass,
|
||||||
, nbNavbarClass, nbContainerClass, nbListItemClass
|
nbButtonClass,
|
||||||
, colorRed, colorYellow, colorGreen
|
nbInputClass,
|
||||||
) where
|
nbLabelClass,
|
||||||
|
nbBadgeClass,
|
||||||
|
nbFontHeading1Class,
|
||||||
|
nbFontHeading2Class,
|
||||||
|
nbNavbarClass,
|
||||||
|
nbContainerClass,
|
||||||
|
nbListItemClass,
|
||||||
|
colorRed,
|
||||||
|
colorYellow,
|
||||||
|
colorGreen,
|
||||||
|
) where
|
||||||
|
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
|
|
||||||
|
|||||||
@@ -3,11 +3,11 @@
|
|||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# OPTIONS_GHC -Wno-unused-imports #-}
|
{-# OPTIONS_GHC -Wno-unused-imports #-}
|
||||||
|
|
||||||
module Sis.View.Layout
|
module Sis.View.Layout (
|
||||||
( documentHead
|
documentHead,
|
||||||
, navbar
|
navbar,
|
||||||
, UserSession (..)
|
UserSession (..),
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
import Data.Default
|
import Data.Default
|
||||||
|
|||||||
Reference in New Issue
Block a user