125 lines
4.5 KiB
Haskell
125 lines
4.5 KiB
Haskell
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
{-# OPTIONS_GHC -Wno-unused-imports -Wno-missing-export-lists -Wno-name-shadowing #-}
|
|
|
|
module Main where
|
|
|
|
import Control.Exception (IOException, catch)
|
|
import Data.ByteString qualified as BS
|
|
import Data.ByteString.Char8 qualified as C8
|
|
import Data.ByteString.Lazy qualified as BL
|
|
import Data.List (isSuffixOf)
|
|
import Effectful
|
|
import Network.HTTP.Types qualified as HTTP
|
|
import Network.Wai qualified as Wai
|
|
import Network.Wai.Handler.Warp qualified as Warp
|
|
import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile)
|
|
import System.Environment (getArgs, lookupEnv)
|
|
import System.FilePath (takeDirectory)
|
|
import System.IO.Error (isDoesNotExistError)
|
|
|
|
import Sis (UserId (..))
|
|
import Sis.Database
|
|
import Sis.Page.Activity
|
|
import Sis.Page.Chores
|
|
import Sis.Page.Dashboard
|
|
import Sis.Page.Household
|
|
import Sis.Page.Login
|
|
import Sis.Page.Signup
|
|
import Sis.Route
|
|
import Sis.View.Layout (UserSession (..), documentHead)
|
|
import Web.Hyperbole
|
|
import Web.Hyperbole.Application
|
|
import Web.Hyperbole.Effect.Response
|
|
import Web.Hyperbole.Page
|
|
import Web.Hyperbole.Route
|
|
|
|
-- Simple MIME type resolver for static files
|
|
mimeType :: FilePath -> BS.ByteString
|
|
mimeType fp
|
|
| ".css" `isSuffixOf` fp = "text/css"
|
|
| ".js" `isSuffixOf` fp = "application/javascript"
|
|
| ".json" `isSuffixOf` fp = "application/json"
|
|
| ".png" `isSuffixOf` fp = "image/png"
|
|
| ".svg" `isSuffixOf` fp = "image/svg+xml"
|
|
| otherwise = "application/octet-stream"
|
|
|
|
main :: IO ()
|
|
main = do
|
|
args <- getArgs
|
|
let dbPath = case args of
|
|
("--db" : p : _) -> p
|
|
_ -> "data/sis.db"
|
|
|
|
-- Use PORT env var or --port arg or default 8080
|
|
mPortEnv <- lookupEnv "PORT"
|
|
mPortArg <- lookupEnv "SIS_PORT"
|
|
let port = case (mPortEnv, mPortArg, args) of
|
|
(Just p, _, _) -> read p
|
|
(_, Just p, _) -> read p
|
|
(_, _, "--port" : p : _) -> read p
|
|
_ -> 8080
|
|
-- For fresh test databases, remove the file so tables are recreated
|
|
rmDB <- lookupEnv "SIS_FRESH_DB"
|
|
case rmDB of
|
|
Just _ -> removeFile dbPath `catch` (\(_ :: IOException) -> pure ())
|
|
Nothing -> pure ()
|
|
createDirectoryIfMissing True (takeDirectory dbPath)
|
|
|
|
putStrLn "[sis] opening database..."
|
|
conn <- openDatabase dbPath
|
|
|
|
putStrLn $ "[sis] listening on 0.0.0.0:" <> show port
|
|
|
|
let hyperboleApp =
|
|
liveAppWith
|
|
( ServerOptions
|
|
{ toDocument = document documentHead
|
|
, serverError = defaultError
|
|
, parseRequestBody = defaultParseRequestBodyOptions
|
|
}
|
|
)
|
|
(runDB conn $ routeRequest router)
|
|
|
|
-- Serve static files under /static/, fall through to Hyperbole app
|
|
let staticDir = "frontend/static"
|
|
Warp.run port $ \req respond -> do
|
|
let rawPath = Wai.rawPathInfo req
|
|
if "/static/" `BS.isPrefixOf` rawPath
|
|
then do
|
|
let relPath = C8.unpack (C8.drop (C8.length "/static") rawPath)
|
|
filePath = staticDir ++ relPath
|
|
exists <- doesFileExist filePath
|
|
if exists
|
|
then do
|
|
content <- BS.readFile filePath
|
|
let ct = mimeType filePath
|
|
respond $ Wai.responseLBS HTTP.status200 [("Content-Type", ct)] (BL.fromStrict content)
|
|
else respond $ Wai.responseLBS HTTP.status404 [] "File not found"
|
|
else hyperboleApp req respond
|
|
|
|
router :: (Hyperbole :> es, DB :> es, IOE :> es) => AppRoute -> Eff es Response
|
|
router Home = do
|
|
redirect (routeUri RDashboard)
|
|
router RLogin = runPage Sis.Page.Login.page
|
|
router RSignup = runPage Sis.Page.Signup.page
|
|
router RDashboard = runPage Sis.Page.Dashboard.page
|
|
router RChores = runPage Sis.Page.Chores.page
|
|
router RHousehold = runPage Sis.Page.Household.page
|
|
router RActivity = runPage Sis.Page.Activity.page
|
|
router (RInvite code) = do
|
|
mSession <- lookupSession @UserSession
|
|
case mSession of
|
|
Nothing -> redirect (routeUri RLogin)
|
|
Just us -> do
|
|
mHousehold <- acceptInvite (UserId (usUserId us)) (unInviteCode code)
|
|
case mHousehold of
|
|
Just _ -> redirect (routeUri RDashboard)
|
|
Nothing -> redirect (routeUri RHousehold)
|
|
router RSeed = do
|
|
seed
|
|
redirect (routeUri RDashboard)
|