86 lines
3.0 KiB
Haskell
86 lines
3.0 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Lisa
|
|
( app
|
|
, mkConfig
|
|
) where
|
|
|
|
import Control.Monad.IO.Class (MonadIO)
|
|
import Data.Maybe (fromMaybe)
|
|
import Data.Text (Text)
|
|
import Network.HTTP.Types.Status (Status, badRequest400, internalServerError500)
|
|
import Text.Blaze.Html (Html)
|
|
import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
|
|
import Web.Internal.HttpApiData (FromHttpApiData)
|
|
import Web.Spock (ActionCtxT, SpockM, get, lazyBytes, modifySession, param, post, readSession, redirect, request, root, setHeader, setStatus, text, var, (<//>))
|
|
import Web.Spock.Config (PoolOrConn(PCNoDatabase), SpockCfg, defaultSpockCfg)
|
|
|
|
import Lisa.Types (Session, State, getAllLecturesCached, getLectureByIdCached, emtpySession, mkState, setSessionAuthToken)
|
|
|
|
import qualified Lisa.Squeak as Squeak
|
|
import qualified Lisa.Views as Views
|
|
|
|
-- Utilities
|
|
|
|
-- From https://github.com/Rockfordal/spockmini/blob/51af99760bbf68c956e906c9633182700a18be9c/src/Web/Utils.hs#L17
|
|
blaze :: MonadIO m => Html -> ActionCtxT ctx m a
|
|
blaze html = do
|
|
setHeader "Content-Type" "text/html; charset=utf-8"
|
|
lazyBytes $ renderHtml html
|
|
|
|
-- | Like 'Web.Spock.param'', but uses status 400 instead of 500.
|
|
requiredParam :: (FromHttpApiData a, MonadIO m) => Text -> ActionCtxT ctx m a
|
|
requiredParam k = param k >>= \case
|
|
Nothing -> do
|
|
setStatus badRequest400
|
|
text $ "Parameter " <> k <> " is required"
|
|
Just val ->
|
|
pure val
|
|
|
|
-- TODO: Generalize, introduce some sort of Lisa.Types.Error type
|
|
-- TODO: Make more readable
|
|
onLeft :: MonadIO m => (ActionCtxT ctx m (Either e a)) -> (Status, Text) -> ActionCtxT ctx m a
|
|
onLeft f (status, message) = f >>= (flip either pure $ \_ -> do
|
|
setStatus status
|
|
text message)
|
|
|
|
-- Exports
|
|
|
|
mkConfig :: IO (SpockCfg () Session State)
|
|
mkConfig = do
|
|
state <- mkState
|
|
defaultSpockCfg emtpySession PCNoDatabase state
|
|
|
|
app :: SpockM () Session State ()
|
|
app = do
|
|
get root $ do
|
|
blaze Views.viewIndex
|
|
|
|
get ("lectures" <//> var) $ \lid -> do
|
|
lecture <- getLectureByIdCached lid `onLeft` (internalServerError500, "Failed to retrieve lectures")
|
|
documents <- Squeak.getDocumentsByLectureId lid `onLeft` (internalServerError500, "Failed to retrieve documents")
|
|
blaze $ Views.viewLecture lecture documents
|
|
|
|
get "lectures" $ do
|
|
query <- fromMaybe "" <$> param "query"
|
|
lectures <- getAllLecturesCached
|
|
blaze $ either Views.viewSqueakError (Views.viewLectures query) lectures
|
|
|
|
get "login" $ blaze Views.viewLogin
|
|
|
|
post "login" $ do
|
|
username <- requiredParam "username"
|
|
password <- requiredParam "password"
|
|
|
|
Squeak.login username password >>= \case
|
|
Left err -> blaze $ Views.viewSqueakError err
|
|
Right (Squeak.Credentials authToken _user) -> do
|
|
modifySession $ setSessionAuthToken authToken
|
|
redirect "/"
|
|
|
|
get "debug" $ do
|
|
req <- request
|
|
sess <- readSession
|
|
blaze $ Views.viewDebug req sess
|