diff --git a/app/Main.hs b/app/Main.hs index dcf4f94..0aa8595 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -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 - (ServerOptions + 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 diff --git a/src/Sis/Database.hs b/src/Sis/Database.hs index ad02886..1dcf778 100644 --- a/src/Sis/Database.hs +++ b/src/Sis/Database.hs @@ -5,36 +5,35 @@ {-# 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 - ) where + -- * DB operations (convenience wrappers) + findUserByEmail, + createUser, + getUser, + getUserHouseholds, + getHousehold, + createHousehold, + getMembers, + getChores, + createChore, + updateChore, + deleteChore, + getDashboard, + recordActivity, + getActivityLog, + createInvite, + getInvites, + revokeInvite, + acceptInvite, + seed, +) where import Control.Monad (when) 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 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,83 +87,96 @@ 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 - "SELECT id, display_name, email, password_hash FROM users WHERE email = ?" - (Only email) + 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 - "SELECT id, display_name, email, password_hash FROM users WHERE id = ?" - (Only uid) + 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 - "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) + 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 - "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) + 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 - "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] - + 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 + ] GetChores hid -> liftIO $ do - 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 - , choreHouseholdId = HouseholdId hId - , choreName = cname - , choreAssignee = mkAssignee atype auid - , choreSchedule = mkSchedule sData - , choreNotifyOnDue = nud /= 0 - , choreCreatedAt = createdAt - } - | (cid, hId, cname, atype, auid, sData, nud, createdAt) <- chores] + 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 + , choreHouseholdId = HouseholdId hId + , choreName = cname + , choreAssignee = mkAssignee atype auid + , choreSchedule = mkSchedule sData + , choreNotifyOnDue = nud /= 0 + , choreCreatedAt = createdAt + } + | (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 - "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 - "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 - "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) + [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 + "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 + "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 - "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)] + 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)] 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 - "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)] + 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)] 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 - "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 - "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)] + [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 + "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)] 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 - "SELECT id, household_id, code, email, status, created_at FROM invites WHERE household_id = ?" - (Only hid) :: IO [(Int, Int, Text, Maybe Text, Text, UTCTime)] + 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)] 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 - "SELECT id, household_id FROM invites WHERE code = ? AND status = 'pending'" - (Only code) :: IO [(Int, Int)] + result <- + SQL.query + conn + "SELECT id, household_id FROM invites WHERE code = ? AND status = 'pending'" + (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 - "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)] + 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)] 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) diff --git a/src/Sis/Page/Activity.hs b/src/Sis/Page/Activity.hs index 5f935d1..c954166 100644 --- a/src/Sis/Page/Activity.hs +++ b/src/Sis/Page/Activity.hs @@ -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 diff --git a/src/Sis/Page/Chores.hs b/src/Sis/Page/Chores.hs index c64a8b6..8f84d98 100644 --- a/src/Sis/Page/Chores.hs +++ b/src/Sis/Page/Chores.hs @@ -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 diff --git a/src/Sis/Page/Dashboard.hs b/src/Sis/Page/Dashboard.hs index e0e1529..b21d114 100644 --- a/src/Sis/Page/Dashboard.hs +++ b/src/Sis/Page/Dashboard.hs @@ -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 diff --git a/src/Sis/Page/Household.hs b/src/Sis/Page/Household.hs index 1426ecb..bfd0b0c 100644 --- a/src/Sis/Page/Household.hs +++ b/src/Sis/Page/Household.hs @@ -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 diff --git a/src/Sis/Page/Login.hs b/src/Sis/Page/Login.hs index b9a7cc0..5648a37 100644 --- a/src/Sis/Page/Login.hs +++ b/src/Sis/Page/Login.hs @@ -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) diff --git a/src/Sis/Page/Signup.hs b/src/Sis/Page/Signup.hs index 8a30823..12b34eb 100644 --- a/src/Sis/Page/Signup.hs +++ b/src/Sis/Page/Signup.hs @@ -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) diff --git a/src/Sis/Style.hs b/src/Sis/Style.hs index b2dd053..b93531c 100644 --- a/src/Sis/Style.hs +++ b/src/Sis/Style.hs @@ -1,13 +1,23 @@ {-# 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 - ) where +{- | 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) diff --git a/src/Sis/View/Layout.hs b/src/Sis/View/Layout.hs index 6b4559f..e512f04 100644 --- a/src/Sis/View/Layout.hs +++ b/src/Sis/View/Layout.hs @@ -3,11 +3,11 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-unused-imports #-} -module Sis.View.Layout - ( documentHead - , navbar - , UserSession (..) - ) where +module Sis.View.Layout ( + documentHead, + navbar, + UserSession (..), +) where import Data.Aeson import Data.Default