Merge branch '93-implement-errorhandler' into 'master'
Resolve "Implement errorHandler" See merge request !85
This commit is contained in:
Gregor Kleen
commit
8a1ea8f0ff
2
.gitignore
vendored
2
.gitignore
vendored
@ -1,8 +1,6 @@
|
||||
dist*
|
||||
static/tmp/
|
||||
static/combined/
|
||||
client_session_key.aes
|
||||
cryptoid_key.bf
|
||||
*.hi
|
||||
*.o
|
||||
*.sqlite3
|
||||
|
||||
@ -26,6 +26,7 @@ job-stale-threshold: 300
|
||||
notification-rate-limit: 3600
|
||||
notification-collate-delay: 300
|
||||
notification-expiration: 259201
|
||||
session-timeout: 7200
|
||||
|
||||
log-settings:
|
||||
log-detailed: "_env:DETAILED_LOGGING:false"
|
||||
@ -41,10 +42,12 @@ auth-pw-hash:
|
||||
strength: 14
|
||||
|
||||
# Optional values with the following production defaults.
|
||||
# In development, they default to true.
|
||||
# In development, they default to the opposite.
|
||||
# reload-templates: false
|
||||
# mutable-static: false
|
||||
# skip-combining: false
|
||||
# encrypt-errors: true
|
||||
encrypt-errors: true
|
||||
|
||||
database:
|
||||
user: "_env:PGUSER:uniworx"
|
||||
@ -86,5 +89,4 @@ user-defaults:
|
||||
time-format: "%R"
|
||||
download-files: false
|
||||
|
||||
cryptoid-keyfile: "_env:CRYPTOID_KEYFILE:cryptoid_key.bf"
|
||||
instance-idfile: "_env:INSTANCEID_FILE:instance"
|
||||
instance-idfile: "_env:INSTANCE_ID:instance"
|
||||
|
||||
@ -376,7 +376,7 @@ NotificationTriggerSubmissionRated: Meine Abgabe wurde korrigiert
|
||||
NotificationTriggerSheetActive: Ich kann ein neues Übungsblatt herunterladen
|
||||
NotificationTriggerSheetSoonInactive: Ich kann ein Übungsblatt bald nicht mehr abgeben
|
||||
NotificationTriggerSheetInactive: Abgabefrist eines meiner Übungsblätter ist abgelaufen
|
||||
NotificationCorrectionsAssigned: Mir wurden Abgaben zur Korrektur zugeteilt
|
||||
NotificationTriggerCorrectionsAssigned: Mir wurden Abgaben zur Korrektur zugeteilt
|
||||
|
||||
CorrCreate: Abgaben erstellen
|
||||
UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}"
|
||||
@ -440,4 +440,18 @@ MessageWarning: Warnung
|
||||
MessageInfo: Information
|
||||
MessageSuccess: Erfolg
|
||||
|
||||
InvalidLangFormat: Ungültiger Sprach-Code (RFC1766)
|
||||
InvalidLangFormat: Ungültiger Sprach-Code (RFC1766)
|
||||
|
||||
ErrorResponseTitleNotFound: Ressource nicht gefunden
|
||||
ErrorResponseTitleInternalError internalError@Text: Ein interner Fehler ist aufgetreten
|
||||
ErrorResponseTitleInvalidArgs invalidArgs@Texts: Anfrage-Nachricht enthielt ungültige Argumente
|
||||
ErrorResponseTitleNotAuthenticated: Anfrage benötigt Authentifizierung
|
||||
ErrorResponseTitlePermissionDenied permissionDenied@Text: Mangelnde Authorisierung
|
||||
ErrorResponseTitleBadMethod requestMethod@Method: HTTP-Methode nicht unterstützt
|
||||
|
||||
UnknownErrorResponse: Ein nicht weiter klassifizierter Fehler ist aufgetreten:
|
||||
ErrorResponseNotFound: Unter der von Ihrem Browser angefragten URL wurde keine Seite gefunden.
|
||||
ErrorResponseNotAuthenticated: Um Zugriff auf einige Teile des Systems zu erhalten müssen Sie sich zunächst anmelden.
|
||||
ErrorResponseBadMethod requestMethodText@Text: Ihr Browser kann auf mehrere verschiedene Arten versuchen mit den vom System angebotenen Ressourcen zu interagieren. Die aktuell versuchte Methode (#{requestMethodText}) wird nicht unterstützt.
|
||||
|
||||
ErrorResponseEncrypted: Um keine sensiblen Daten preiszugeben wurden nähere Details verschlüsselt. Wenn Sie eine Anfrage an den Support schicken fügen Sie bitte die unten aufgeführten verschlüsselten Daten mit an.
|
||||
6
models
6
models
@ -255,4 +255,8 @@ SystemMessageTranslation
|
||||
language Lang
|
||||
content Html
|
||||
summary Html Maybe
|
||||
UniqueSystemMessageTranslation message language
|
||||
UniqueSystemMessageTranslation message language
|
||||
ClusterConfig
|
||||
setting ClusterSettingsKey
|
||||
value Value
|
||||
Primary setting
|
||||
@ -48,6 +48,7 @@ dependencies:
|
||||
- wai
|
||||
- cryptonite
|
||||
- cryptonite-conduit
|
||||
- saltine
|
||||
- base64-bytestring
|
||||
- memory
|
||||
- http-api-data
|
||||
@ -67,6 +68,7 @@ dependencies:
|
||||
- cryptoids
|
||||
- cryptoids-class
|
||||
- binary
|
||||
- cereal
|
||||
- mtl
|
||||
- sandi
|
||||
- esqueleto
|
||||
@ -107,6 +109,7 @@ dependencies:
|
||||
- postgresql-simple
|
||||
- word24
|
||||
- mmorph
|
||||
- clientsession
|
||||
|
||||
# The library contains all of our application code. The executable
|
||||
# defined below is just a thin wrapper.
|
||||
|
||||
@ -6,6 +6,9 @@
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module Application
|
||||
( getApplicationDev, getAppDevSettings
|
||||
@ -26,7 +29,7 @@ module Application
|
||||
import Control.Monad.Logger (liftLoc, LoggingT(..), MonadLoggerIO(..))
|
||||
import Database.Persist.Postgresql (createPostgresqlPool, pgConnStr,
|
||||
pgPoolSize, runSqlPool)
|
||||
import Import
|
||||
import Import hiding (Proxy)
|
||||
import Language.Haskell.TH.Syntax (qLocation)
|
||||
import Network.Wai (Middleware)
|
||||
import Network.Wai.Handler.Warp (Settings, defaultSettings,
|
||||
@ -67,6 +70,12 @@ import qualified Yesod.Core.Types as Yesod (Logger(..))
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
|
||||
import Control.Lens ((&))
|
||||
|
||||
import Data.Proxy
|
||||
|
||||
import qualified Data.Aeson as Aeson
|
||||
|
||||
import System.Exit (exitFailure)
|
||||
|
||||
-- Import all relevant handler modules here.
|
||||
-- (HPack takes care to add new modules to our cabal file nowadays.)
|
||||
@ -105,8 +114,7 @@ makeFoundation appSettings@(AppSettings{..}) = do
|
||||
return $ Yesod.Logger loggerSet tgetter
|
||||
appStatic <- liftIO $ bool static staticDevel appMutableStatic appStaticDir
|
||||
|
||||
appCryptoIDKey <- readKeyFile appCryptoIDKeyFile
|
||||
appInstanceID <- liftIO $ maybe UUID.nextRandom readInstanceIDFile appInstanceIDFile
|
||||
appInstanceID <- liftIO $ maybe UUID.nextRandom (either readInstanceIDFile return) appInitialInstanceID
|
||||
|
||||
(appJobCtl, recvChans) <- fmap unzip . atomically . replicateM appJobWorkers $ do
|
||||
chan <- newBroadcastTMChan
|
||||
@ -120,11 +128,16 @@ makeFoundation appSettings@(AppSettings{..}) = do
|
||||
-- logging function. To get out of this loop, we initially create a
|
||||
-- temporary foundation without a real connection pool, get a log function
|
||||
-- from there, and then create the real foundation.
|
||||
let mkFoundation appConnPool appSmtpPool = UniWorX {..}
|
||||
let mkFoundation appConnPool appSmtpPool appCryptoIDKey appSessionKey appErrorMsgKey = UniWorX {..}
|
||||
-- The UniWorX {..} syntax is an example of record wild cards. For more
|
||||
-- information, see:
|
||||
-- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
|
||||
tempFoundation = mkFoundation (error "connPool forced in tempFoundation") (error "smtpPool forced in tempFoundation")
|
||||
tempFoundation = mkFoundation
|
||||
(error "connPool forced in tempFoundation")
|
||||
(error "smtpPool forced in tempFoundation")
|
||||
(error "cryptoIDKey forced in tempFoundation")
|
||||
(error "sessionKey forced in tempFoundation")
|
||||
(error "errorMsgKey forced in tempFoundation")
|
||||
logFunc = messageLoggerSource tempFoundation appLogger
|
||||
|
||||
flip runLoggingT logFunc $ do
|
||||
@ -140,12 +153,38 @@ makeFoundation appSettings@(AppSettings{..}) = do
|
||||
|
||||
-- Perform database migration using our application's logging settings.
|
||||
migrateAll `runSqlPool` sqlPool
|
||||
appCryptoIDKey <- clusterSetting (Proxy :: Proxy 'ClusterCryptoIDKey) `runSqlPool` sqlPool
|
||||
appSessionKey <- clusterSetting (Proxy :: Proxy 'ClusterClientSessionKey) `runSqlPool` sqlPool
|
||||
appErrorMsgKey <- if
|
||||
| appEncryptErrors -> Just <$> clusterSetting (Proxy :: Proxy 'ClusterErrorMessageKey) `runSqlPool` sqlPool
|
||||
| otherwise -> return Nothing
|
||||
|
||||
handleJobs recvChans $ mkFoundation sqlPool smtpPool
|
||||
let foundation = mkFoundation sqlPool smtpPool appCryptoIDKey appSessionKey appErrorMsgKey
|
||||
|
||||
handleJobs recvChans foundation
|
||||
|
||||
-- Return the foundation
|
||||
return $ mkFoundation sqlPool smtpPool
|
||||
return foundation
|
||||
|
||||
clusterSetting :: forall key m p.
|
||||
( MonadIO m
|
||||
, ClusterSetting key
|
||||
, MonadLogger m
|
||||
)
|
||||
=> p (key :: ClusterSettingsKey)
|
||||
-> ReaderT SqlBackend m (ClusterSettingValue key)
|
||||
clusterSetting proxy@(knownClusterSetting -> key) = do
|
||||
current' <- get (ClusterConfigKey key)
|
||||
case Aeson.fromJSON . clusterConfigValue <$> current' of
|
||||
Just (Aeson.Success c) -> return c
|
||||
Just (Aeson.Error str) -> do
|
||||
$logErrorS "clusterSetting" $ "Could not parse JSON-Value for " <> toPathPiece key
|
||||
liftIO exitFailure
|
||||
Nothing -> do
|
||||
new <- initClusterSetting proxy
|
||||
void . insert $ ClusterConfig key (Aeson.toJSON new)
|
||||
return new
|
||||
|
||||
readInstanceIDFile :: MonadIO m => FilePath -> m UUID
|
||||
readInstanceIDFile idFile = liftIO . handle generateInstead $ LBS.readFile idFile >>= parseBS
|
||||
where
|
||||
|
||||
@ -20,6 +20,8 @@ import Database.Persist.Sql (ConnectionPool, runSqlPool)
|
||||
import Text.Hamlet (hamletFile)
|
||||
import Text.Jasmine (minifym)
|
||||
|
||||
import qualified Web.ClientSession as ClientSession
|
||||
|
||||
import Yesod.Auth.Message
|
||||
import Yesod.Auth.Dummy
|
||||
import Auth.LDAP
|
||||
@ -96,6 +98,10 @@ import qualified Yesod.Auth.Message as Auth
|
||||
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
import qualified Crypto.Saltine.Core.SecretBox as SecretBox
|
||||
import qualified Crypto.Saltine.Class as Saltine
|
||||
import qualified Data.Binary as Binary
|
||||
|
||||
|
||||
instance DisplayAble b => DisplayAble (E.CryptoID a b) where
|
||||
display = display . ciphertext
|
||||
@ -127,6 +133,8 @@ data UniWorX = UniWorX
|
||||
, appCryptoIDKey :: CryptoIDKey
|
||||
, appInstanceID :: InstanceId
|
||||
, appJobCtl :: [TMChan JobCtl]
|
||||
, appErrorMsgKey :: Maybe SecretBox.Key
|
||||
, appSessionKey :: ClientSession.Key
|
||||
}
|
||||
|
||||
type SMTPPool = Pool SMTPConnection
|
||||
@ -197,14 +205,8 @@ instance RenderMessage UniWorX TermIdentifier where
|
||||
Winter -> renderMessage' $ MsgWinterTerm year
|
||||
where renderMessage' = renderMessage foundation ls
|
||||
|
||||
instance RenderMessage UniWorX StudyFieldType where
|
||||
renderMessage foundation ls = renderMessage foundation ls . \case
|
||||
FieldPrimary -> MsgFieldPrimary
|
||||
FieldSecondary -> MsgFieldSecondary
|
||||
|
||||
newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier
|
||||
deriving (Eq, Ord, Read, Show)
|
||||
|
||||
instance RenderMessage UniWorX ShortTermIdentifier where
|
||||
renderMessage foundation ls (ShortTermIdentifier TermIdentifier{..}) = case season of
|
||||
Summer -> renderMessage' $ MsgSummerTermShort year
|
||||
@ -214,33 +216,12 @@ instance RenderMessage UniWorX ShortTermIdentifier where
|
||||
instance RenderMessage UniWorX String where
|
||||
renderMessage f ls str = renderMessage f ls $ Text.pack str
|
||||
|
||||
instance RenderMessage UniWorX SheetFileType where
|
||||
renderMessage foundation ls = renderMessage foundation ls . \case
|
||||
SheetExercise -> MsgSheetExercise
|
||||
SheetHint -> MsgSheetHint
|
||||
SheetSolution -> MsgSheetSolution
|
||||
SheetMarking -> MsgSheetMarking
|
||||
|
||||
instance RenderMessage UniWorX CorrectorState where
|
||||
renderMessage foundation ls = renderMessage foundation ls . \case
|
||||
CorrectorNormal -> MsgCorrectorNormal
|
||||
CorrectorMissing -> MsgCorrectorMissing
|
||||
CorrectorExcused -> MsgCorrectorExcused
|
||||
|
||||
|
||||
instance RenderMessage UniWorX Load where
|
||||
renderMessage foundation ls = renderMessage foundation ls . \case
|
||||
(Load {byTutorial=Nothing , byProportion=p}) -> MsgCorByProportionOnly p
|
||||
(Load {byTutorial=Just True , byProportion=p}) -> MsgCorByProportionIncludingTutorial p
|
||||
(Load {byTutorial=Just False, byProportion=p}) -> MsgCorByProportionExcludingTutorial p
|
||||
|
||||
instance RenderMessage UniWorX SheetType where
|
||||
renderMessage foundation ls = renderMessage foundation ls . \case
|
||||
Bonus{..} -> MsgSheetTypeBonus' maxPoints
|
||||
Normal{..} -> MsgSheetTypeNormal' maxPoints
|
||||
Pass{..} -> MsgSheetTypePass' maxPoints passingPoints
|
||||
NotGraded{} -> MsgSheetTypeNotGraded'
|
||||
|
||||
newtype MsgLanguage = MsgLanguage Lang
|
||||
deriving (Eq, Ord, Show, Read)
|
||||
instance RenderMessage UniWorX MsgLanguage where
|
||||
@ -250,24 +231,18 @@ instance RenderMessage UniWorX MsgLanguage where
|
||||
where
|
||||
mr = renderMessage foundation ls
|
||||
|
||||
instance RenderMessage UniWorX NotificationTrigger where
|
||||
renderMessage foundation ls = renderMessage foundation ls . \case
|
||||
NTSubmissionRatedGraded -> MsgNotificationTriggerSubmissionRatedGraded
|
||||
NTSubmissionRated -> MsgNotificationTriggerSubmissionRated
|
||||
NTSheetActive -> MsgNotificationTriggerSheetActive
|
||||
NTSheetSoonInactive -> MsgNotificationTriggerSheetSoonInactive
|
||||
NTSheetInactive -> MsgNotificationTriggerSheetInactive
|
||||
NTCorrectionsAssigned -> MsgNotificationCorrectionsAssigned
|
||||
|
||||
instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where
|
||||
renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route)
|
||||
|
||||
instance RenderMessage UniWorX MessageClass where
|
||||
renderMessage f ls = renderMessage f ls . \case
|
||||
Error -> MsgMessageError
|
||||
Warning -> MsgMessageWarning
|
||||
Info -> MsgMessageInfo
|
||||
Success -> MsgMessageSuccess
|
||||
embedRenderMessage ''UniWorX ''MessageClass ("Message" <>)
|
||||
embedRenderMessage ''UniWorX ''NotificationTrigger $ ("NotificationTrigger" <>) . concat . drop 1 . splitCamel
|
||||
embedRenderMessage ''UniWorX ''SheetType $ \st -> "SheetType" <> st <> "'"
|
||||
embedRenderMessage ''UniWorX ''StudyFieldType id
|
||||
embedRenderMessage ''UniWorX ''SheetFileType id
|
||||
embedRenderMessage ''UniWorX ''CorrectorState id
|
||||
|
||||
newtype ErrorResponseTitle = ErrorResponseTitle ErrorResponse
|
||||
embedRenderMessageVariant ''UniWorX ''ErrorResponseTitle ("ErrorResponseTitle" <>)
|
||||
|
||||
|
||||
data instance ButtonCssClass UniWorX = BCDefault | BCPrimary | BCSuccess | BCInfo | BCWarning | BCDanger | BCLink
|
||||
@ -573,9 +548,9 @@ instance Yesod UniWorX where
|
||||
|
||||
-- Store session data on the client in encrypted cookies,
|
||||
-- default session idle timeout is 120 minutes
|
||||
makeSessionBackend _ = Just <$> defaultClientSessionBackend
|
||||
120 -- timeout in minutes
|
||||
"client_session_key.aes"
|
||||
makeSessionBackend UniWorX{appSessionKey,appSettings=AppSettings{appSessionTimeout}} = do
|
||||
(getCachedDate, _) <- clientSessionDateCacher appSessionTimeout
|
||||
return . Just $ clientSessionBackend appSessionKey getCachedDate
|
||||
|
||||
maximumContentLength _ _ = Just $ 50 * 2^20
|
||||
|
||||
@ -627,101 +602,49 @@ instance Yesod UniWorX where
|
||||
$logDebugS "normalizeRouteMiddleware" [st|Redirecting to #{tshow route'}|]
|
||||
redirectWith movedPermanently301 route'
|
||||
|
||||
defaultLayout widget = do
|
||||
master <- getYesod
|
||||
let AppSettings { appUserDefaults = UserDefaultConf{..}, .. } = appSettings master
|
||||
-- Since we implement `errorHandler` ourselves we don't need `defaultMessageWidget`
|
||||
defaultMessageWidget _title _body = error "defaultMessageWidget: undefined"
|
||||
|
||||
applySystemMessages
|
||||
mmsgs <- getMessages
|
||||
errorHandler err = do
|
||||
mr <- getMessageRender
|
||||
let
|
||||
encrypted :: ToJSON a => a -> Widget -> Widget
|
||||
encrypted plaintextJson plaintext = do
|
||||
errKey <- getsYesod appErrorMsgKey
|
||||
case errKey of
|
||||
Nothing -> plaintext
|
||||
Just key -> do
|
||||
nonce <- liftIO SecretBox.newNonce
|
||||
let ciphertext = SecretBox.secretbox key nonce . Lazy.ByteString.toStrict $ encode plaintextJson
|
||||
encoded = decodeUtf8 . Base64.encode . Lazy.ByteString.toStrict $ Binary.encode (Saltine.encode nonce, ciphertext)
|
||||
formatted = Text.intercalate "\n" . map (Text.intercalate " " . Text.chunksOf 4) $ Text.chunksOf 72 encoded
|
||||
[whamlet|
|
||||
<p>_{MsgErrorResponseEncrypted}
|
||||
<pre .errMsg>
|
||||
#{formatted}
|
||||
|]
|
||||
|
||||
errPage = case err of
|
||||
NotFound -> [whamlet|<p>_{MsgErrorResponseNotFound}|]
|
||||
InternalError err -> encrypted err [whamlet|<p .errMsg>#{err}|]
|
||||
InvalidArgs errs -> [whamlet|
|
||||
<ul>
|
||||
$forall err <- errs
|
||||
<li .errMsg>#{err}
|
||||
|]
|
||||
NotAuthenticated -> [whamlet|<p>_{MsgErrorResponseNotAuthenticated}|]
|
||||
PermissionDenied err -> [whamlet|<p .errMsg>#{err}|]
|
||||
BadMethod method -> [whamlet|<p>_{MsgErrorResponseBadMethod (decodeUtf8 method)}|]
|
||||
fmap toTypedContent . siteLayout (Just . toHtml . mr $ ErrorResponseTitle err) $ do
|
||||
toWidget
|
||||
[cassius|
|
||||
.errMsg
|
||||
white-space: pre-wrap
|
||||
font-family: monospace
|
||||
|]
|
||||
errPage
|
||||
|
||||
mcurrentRoute <- getCurrentRoute
|
||||
|
||||
-- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance.
|
||||
(title, parents) <- breadcrumbs
|
||||
|
||||
-- let isParent :: Route UniWorX -> Bool
|
||||
-- isParent r = r == (fst parents)
|
||||
|
||||
let menu = defaultLinks ++ maybe [] pageActions mcurrentRoute
|
||||
|
||||
menuTypes <- mapM (\x -> (x, ) <$> newIdent) =<< filterM (menuItemAccessCallback . menuItem) menu
|
||||
|
||||
isAuth <- isJust <$> maybeAuthId
|
||||
|
||||
-- Lookup Favourites & Theme if possible -- TODO: cache this info in a cookie?!
|
||||
(favourites', currentTheme) <- do
|
||||
muid <- maybeAuthPair
|
||||
case muid of
|
||||
Nothing -> return ([],userDefaultTheme)
|
||||
(Just (uid,user)) -> do
|
||||
favs <- runDB $ E.select . E.from $ \(course `E.InnerJoin` courseFavourite) -> do
|
||||
E.on (course E.^. CourseId E.==. courseFavourite E.^. CourseFavouriteCourse)
|
||||
E.where_ (courseFavourite E.^. CourseFavouriteUser E.==. E.val uid)
|
||||
E.orderBy [ E.asc $ course E.^. CourseShorthand ]
|
||||
return course
|
||||
return (favs, userTheme user)
|
||||
favourites <- forM favourites' $ \(Entity _ c@Course{..})
|
||||
-> let
|
||||
courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR
|
||||
in (c, courseRoute, ) <$> filterM (menuItemAccessCallback . menuItem) (pageActions courseRoute)
|
||||
|
||||
let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority
|
||||
highlight = let crumbs = mcons mcurrentRoute $ fst <$> reverse parents
|
||||
navItems = map snd3 favourites ++ map (menuItemRoute . menuItem . fst) menuTypes
|
||||
highR = find (`elem` navItems) . uncurry (++) $ partition (`elem` map snd3 favourites) crumbs
|
||||
in \r -> Just r == highR
|
||||
favouriteTerms :: [TermIdentifier]
|
||||
favouriteTerms = Set.toDescList $ foldMap (\(Course{..}, _, _) -> Set.singleton $ unTermKey courseTerm) favourites
|
||||
favouriteTerm :: TermIdentifier -> [(Course, Route UniWorX, [MenuTypes])]
|
||||
favouriteTerm tid = filter (\(Course{..}, _, _) -> unTermKey courseTerm == tid) favourites
|
||||
|
||||
-- We break up the default layout into two components:
|
||||
-- default-layout is the contents of the body tag, and
|
||||
-- default-layout-wrapper is the entire page. Since the final
|
||||
-- value passed to hamletToRepHtml cannot be a widget, this allows
|
||||
-- you to use normal widget features in default-layout.
|
||||
|
||||
|
||||
let
|
||||
navbar :: Widget
|
||||
navbar = $(widgetFile "widgets/navbar")
|
||||
asidenav :: Widget
|
||||
asidenav = $(widgetFile "widgets/asidenav")
|
||||
contentHeadline :: Maybe Widget
|
||||
contentHeadline = pageHeading =<< mcurrentRoute
|
||||
breadcrumbs :: Widget
|
||||
breadcrumbs = $(widgetFile "widgets/breadcrumbs")
|
||||
pageactionprime :: Widget
|
||||
pageactionprime = $(widgetFile "widgets/pageactionprime") -- TODO: rename, since it also shows secondary pageActions now
|
||||
-- functions to determine if there are page-actions (primary or secondary)
|
||||
isPageActionPrime :: MenuTypes -> Bool
|
||||
isPageActionPrime (PageActionPrime _) = True
|
||||
isPageActionPrime (PageActionSecondary _) = True
|
||||
isPageActionPrime _ = False
|
||||
hasPageActions :: Bool
|
||||
hasPageActions = any (isPageActionPrime . fst) menuTypes
|
||||
|
||||
pc <- widgetToPageContent $ do
|
||||
addStylesheetRemote "https://fonts.googleapis.com/css?family=Source+Sans+Pro:300,400,600,800,900|Roboto:300,400,600"
|
||||
addScript $ StaticR js_zepto_js
|
||||
addScript $ StaticR js_fetchPolyfill_js
|
||||
addScript $ StaticR js_urlPolyfill_js
|
||||
addScript $ StaticR js_featureChecker_js
|
||||
addScript $ StaticR js_flatpickr_js
|
||||
addScript $ StaticR js_tabber_js
|
||||
addStylesheet $ StaticR css_flatpickr_css
|
||||
addStylesheet $ StaticR css_tabber_css
|
||||
addStylesheet $ StaticR css_fonts_css
|
||||
addStylesheet $ StaticR css_fontawesome_css
|
||||
$(widgetFile "default-layout")
|
||||
$(widgetFile "standalone/modal")
|
||||
$(widgetFile "standalone/showHide")
|
||||
$(widgetFile "standalone/inputs")
|
||||
$(widgetFile "standalone/tooltip")
|
||||
$(widgetFile "standalone/tabber")
|
||||
$(widgetFile "standalone/alerts")
|
||||
$(widgetFile "standalone/datepicker")
|
||||
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
|
||||
defaultLayout = siteLayout Nothing
|
||||
|
||||
-- The page to be redirected to when authentication is required.
|
||||
authRoute _ = Just $ AuthR LoginR
|
||||
@ -768,6 +691,105 @@ instance Yesod UniWorX where
|
||||
makeLogger = return . appLogger
|
||||
|
||||
|
||||
siteLayout :: Maybe Html -- ^ Optionally override `pageHeading`
|
||||
-> Widget -> Handler Html
|
||||
siteLayout headingOverride widget = do
|
||||
master <- getYesod
|
||||
let AppSettings { appUserDefaults = UserDefaultConf{..}, .. } = appSettings master
|
||||
|
||||
applySystemMessages
|
||||
mmsgs <- getMessages
|
||||
|
||||
mcurrentRoute <- getCurrentRoute
|
||||
|
||||
-- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance.
|
||||
(title, parents) <- breadcrumbs
|
||||
|
||||
-- let isParent :: Route UniWorX -> Bool
|
||||
-- isParent r = r == (fst parents)
|
||||
|
||||
let menu = defaultLinks ++ maybe [] pageActions mcurrentRoute
|
||||
|
||||
menuTypes <- mapM (\x -> (x, ) <$> newIdent) =<< filterM (menuItemAccessCallback . menuItem) menu
|
||||
|
||||
isAuth <- isJust <$> maybeAuthId
|
||||
|
||||
-- Lookup Favourites & Theme if possible -- TODO: cache this info in a cookie?!
|
||||
(favourites', currentTheme) <- do
|
||||
muid <- maybeAuthPair
|
||||
case muid of
|
||||
Nothing -> return ([],userDefaultTheme)
|
||||
(Just (uid,user)) -> do
|
||||
favs <- runDB $ E.select . E.from $ \(course `E.InnerJoin` courseFavourite) -> do
|
||||
E.on (course E.^. CourseId E.==. courseFavourite E.^. CourseFavouriteCourse)
|
||||
E.where_ (courseFavourite E.^. CourseFavouriteUser E.==. E.val uid)
|
||||
E.orderBy [ E.asc $ course E.^. CourseShorthand ]
|
||||
return course
|
||||
return (favs, userTheme user)
|
||||
favourites <- forM favourites' $ \(Entity _ c@Course{..})
|
||||
-> let
|
||||
courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR
|
||||
in (c, courseRoute, ) <$> filterM (menuItemAccessCallback . menuItem) (pageActions courseRoute)
|
||||
|
||||
let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority
|
||||
highlight = let crumbs = mcons mcurrentRoute $ fst <$> reverse parents
|
||||
navItems = map snd3 favourites ++ map (menuItemRoute . menuItem . fst) menuTypes
|
||||
highR = find (`elem` navItems) . uncurry (++) $ partition (`elem` map snd3 favourites) crumbs
|
||||
in \r -> Just r == highR
|
||||
favouriteTerms :: [TermIdentifier]
|
||||
favouriteTerms = Set.toDescList $ foldMap (\(Course{..}, _, _) -> Set.singleton $ unTermKey courseTerm) favourites
|
||||
favouriteTerm :: TermIdentifier -> [(Course, Route UniWorX, [MenuTypes])]
|
||||
favouriteTerm tid = filter (\(Course{..}, _, _) -> unTermKey courseTerm == tid) favourites
|
||||
|
||||
-- We break up the default layout into two components:
|
||||
-- default-layout is the contents of the body tag, and
|
||||
-- default-layout-wrapper is the entire page. Since the final
|
||||
-- value passed to hamletToRepHtml cannot be a widget, this allows
|
||||
-- you to use normal widget features in default-layout.
|
||||
|
||||
|
||||
let
|
||||
navbar :: Widget
|
||||
navbar = $(widgetFile "widgets/navbar")
|
||||
asidenav :: Widget
|
||||
asidenav = $(widgetFile "widgets/asidenav")
|
||||
contentHeadline :: Maybe Widget
|
||||
contentHeadline = (toWidget <$> headingOverride) <|> (pageHeading =<< mcurrentRoute)
|
||||
breadcrumbs :: Widget
|
||||
breadcrumbs = $(widgetFile "widgets/breadcrumbs")
|
||||
pageactionprime :: Widget
|
||||
pageactionprime = $(widgetFile "widgets/pageactionprime") -- TODO: rename, since it also shows secondary pageActions now
|
||||
-- functions to determine if there are page-actions (primary or secondary)
|
||||
isPageActionPrime :: MenuTypes -> Bool
|
||||
isPageActionPrime (PageActionPrime _) = True
|
||||
isPageActionPrime (PageActionSecondary _) = True
|
||||
isPageActionPrime _ = False
|
||||
hasPageActions :: Bool
|
||||
hasPageActions = any (isPageActionPrime . fst) menuTypes
|
||||
|
||||
pc <- widgetToPageContent $ do
|
||||
addStylesheetRemote "https://fonts.googleapis.com/css?family=Source+Sans+Pro:300,400,600,800,900|Roboto:300,400,600"
|
||||
addScript $ StaticR js_zepto_js
|
||||
addScript $ StaticR js_fetchPolyfill_js
|
||||
addScript $ StaticR js_urlPolyfill_js
|
||||
addScript $ StaticR js_featureChecker_js
|
||||
addScript $ StaticR js_flatpickr_js
|
||||
addScript $ StaticR js_tabber_js
|
||||
addStylesheet $ StaticR css_flatpickr_css
|
||||
addStylesheet $ StaticR css_tabber_css
|
||||
addStylesheet $ StaticR css_fonts_css
|
||||
addStylesheet $ StaticR css_fontawesome_css
|
||||
$(widgetFile "default-layout")
|
||||
$(widgetFile "standalone/modal")
|
||||
$(widgetFile "standalone/showHide")
|
||||
$(widgetFile "standalone/inputs")
|
||||
$(widgetFile "standalone/tooltip")
|
||||
$(widgetFile "standalone/tabber")
|
||||
$(widgetFile "standalone/alerts")
|
||||
$(widgetFile "standalone/datepicker")
|
||||
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
|
||||
|
||||
|
||||
applySystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX) => m ()
|
||||
applySystemMessages = liftHandlerT . runDB . runConduit $ selectSource [] [] .| C.mapM_ applyMessage
|
||||
where
|
||||
|
||||
@ -279,10 +279,8 @@ helpForm mReferer mUid = HelpForm
|
||||
, (HIAnonymous, pure $ Left Nothing)
|
||||
]
|
||||
|
||||
getHelpR :: Handler Html
|
||||
getHelpR, postHelpR :: Handler Html
|
||||
getHelpR = postHelpR
|
||||
|
||||
postHelpR :: Handler Html
|
||||
postHelpR = do
|
||||
mUid <- maybeAuthId
|
||||
mRefererBS <- requestHeaderReferer <$> waiRequest
|
||||
|
||||
@ -33,6 +33,7 @@ import Data.CaseInsensitive (CI)
|
||||
import Data.CaseInsensitive.Instances ()
|
||||
|
||||
import Utils.Message (MessageClass)
|
||||
import Settings.Cluster (ClusterSettingsKey)
|
||||
|
||||
-- You can define all of your database entities in the entities file.
|
||||
-- You can find more information on persistent and how to declare entities
|
||||
|
||||
@ -7,6 +7,9 @@
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
-- | Settings are centralized, as much as possible, into this file. This
|
||||
@ -14,12 +17,17 @@
|
||||
-- In addition, you can configure a number of different aspects of Yesod
|
||||
-- by overriding methods in the Yesod typeclass. That instance is
|
||||
-- declared in the Foundation.hs file.
|
||||
module Settings where
|
||||
module Settings
|
||||
( module Settings
|
||||
, module Settings.Cluster
|
||||
) where
|
||||
|
||||
import ClassyPrelude.Yesod
|
||||
import ClassyPrelude.Yesod hiding (Proxy)
|
||||
import Data.UUID (UUID)
|
||||
import qualified Control.Exception as Exception
|
||||
import Data.Aeson (Result (..), fromJSON, withObject,
|
||||
(.!=), (.:?), withScientific)
|
||||
import Data.Aeson (Result (..), fromJSON, withObject
|
||||
,(.!=), (.:?), withScientific
|
||||
)
|
||||
import qualified Data.Aeson.Types as Aeson
|
||||
import Data.Aeson.TH
|
||||
import Data.FileEmbed (embedFile)
|
||||
@ -57,6 +65,7 @@ import Network.Mail.Mime (Address)
|
||||
import Mail (VerpMode)
|
||||
|
||||
import Model
|
||||
import Settings.Cluster
|
||||
|
||||
-- | Runtime settings to configure this application. These settings can be
|
||||
-- loaded from various sources: defaults, environment variables, config files,
|
||||
@ -91,6 +100,7 @@ data AppSettings = AppSettings
|
||||
, appNotificationRateLimit :: NominalDiffTime
|
||||
, appNotificationCollateDelay :: NominalDiffTime
|
||||
, appNotificationExpiration :: NominalDiffTime
|
||||
, appSessionTimeout :: NominalDiffTime
|
||||
|
||||
, appInitialLogSettings :: LogSettings
|
||||
|
||||
@ -104,12 +114,12 @@ data AppSettings = AppSettings
|
||||
-- ^ Indicate if auth dummy login should be enabled.
|
||||
, appAllowDeprecated :: Bool
|
||||
-- ^ Indicate if deprecated routes are accessible for everyone
|
||||
, appEncryptErrors :: Bool
|
||||
|
||||
, appUserDefaults :: UserDefaultConf
|
||||
, appAuthPWHash :: PWHashConf
|
||||
|
||||
, appCryptoIDKeyFile :: FilePath
|
||||
, appInstanceIDFile :: Maybe FilePath
|
||||
, appInitialInstanceID :: Maybe (Either FilePath UUID)
|
||||
} deriving (Show)
|
||||
|
||||
data LogSettings = LogSettings
|
||||
@ -264,7 +274,6 @@ deriveFromJSON
|
||||
''Address
|
||||
|
||||
|
||||
|
||||
instance FromJSON AppSettings where
|
||||
parseJSON = withObject "AppSettings" $ \o -> do
|
||||
let defaultDev =
|
||||
@ -298,19 +307,21 @@ instance FromJSON AppSettings where
|
||||
appNotificationCollateDelay <- o .: "notification-collate-delay"
|
||||
appNotificationExpiration <- o .: "notification-expiration"
|
||||
|
||||
appSessionTimeout <- o .: "session-timeout"
|
||||
|
||||
appReloadTemplates <- o .:? "reload-templates" .!= defaultDev
|
||||
appMutableStatic <- o .:? "mutable-static" .!= defaultDev
|
||||
appSkipCombining <- o .:? "skip-combining" .!= defaultDev
|
||||
appAuthDummyLogin <- o .:? "auth-dummy-login" .!= defaultDev
|
||||
appAllowDeprecated <- o .:? "allow-deprecated" .!= defaultDev
|
||||
appEncryptErrors <- o .:? "encrypt-errors" .!= not defaultDev
|
||||
|
||||
appInitialLogSettings <- o .: "log-settings"
|
||||
|
||||
appUserDefaults <- o .: "user-defaults"
|
||||
appAuthPWHash <- o .: "auth-pw-hash"
|
||||
|
||||
appCryptoIDKeyFile <- o .: "cryptoid-keyfile"
|
||||
appInstanceIDFile <- o .:? "instance-idfile"
|
||||
appInitialInstanceID <- (o .:? "instance-id") >>= maybe (return Nothing) (\v -> Just <$> ((Right <$> parseJSON v) <|> (Left <$> parseJSON v)))
|
||||
|
||||
return AppSettings {..}
|
||||
|
||||
|
||||
134
src/Settings/Cluster.hs
Normal file
134
src/Settings/Cluster.hs
Normal file
@ -0,0 +1,134 @@
|
||||
{-# LANGUAGE NoImplicitPrelude
|
||||
, DataKinds
|
||||
, TypeFamilies
|
||||
, ScopedTypeVariables
|
||||
, TemplateHaskell
|
||||
, OverloadedStrings
|
||||
, FlexibleContexts
|
||||
#-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Settings.Cluster
|
||||
( ClusterSettingsKey(..)
|
||||
, ClusterSetting(..)
|
||||
) where
|
||||
|
||||
import ClassyPrelude.Yesod
|
||||
import Database.Persist.Sql
|
||||
import Web.HttpApiData
|
||||
|
||||
import Utils
|
||||
import Control.Lens
|
||||
import Data.Universe
|
||||
|
||||
import Data.Aeson ( FromJSON(..), ToJSON(..)
|
||||
, Options(..), defaultOptions
|
||||
, FromJSONKey(..), ToJSONKey(..), FromJSONKeyFunction(..)
|
||||
)
|
||||
import Data.Aeson.TH (deriveJSON)
|
||||
import Data.Aeson.Types (toJSONKeyText)
|
||||
import qualified Data.Aeson as Aeson
|
||||
|
||||
import qualified Web.ClientSession as ClientSession
|
||||
import qualified Crypto.Saltine.Core.SecretBox as SecretBox
|
||||
import qualified Crypto.Saltine.Class as Saltine
|
||||
|
||||
import Data.CryptoID.ByteString (CryptoIDKey)
|
||||
import qualified Data.CryptoID.ByteString as CryptoID
|
||||
|
||||
import qualified Data.Binary as Binary
|
||||
import qualified Data.Serialize as Serialize
|
||||
import qualified Data.ByteString.Base64.URL as Base64
|
||||
|
||||
|
||||
data ClusterSettingsKey
|
||||
= ClusterCryptoIDKey
|
||||
| ClusterClientSessionKey
|
||||
| ClusterErrorMessageKey
|
||||
deriving (Eq, Ord, Enum, Bounded, Show, Read)
|
||||
|
||||
instance Universe ClusterSettingsKey
|
||||
instance Finite ClusterSettingsKey
|
||||
|
||||
$(return [])
|
||||
|
||||
instance PathPiece ClusterSettingsKey where
|
||||
toPathPiece = $(nullaryToPathPiece ''ClusterSettingsKey [intercalate "-" . map toLower . drop 1 . splitCamel])
|
||||
fromPathPiece = finiteFromPathPiece
|
||||
|
||||
deriveJSON
|
||||
defaultOptions
|
||||
{ constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
|
||||
}
|
||||
''ClusterSettingsKey
|
||||
|
||||
instance ToJSONKey ClusterSettingsKey where
|
||||
toJSONKey = toJSONKeyText $ \v -> let String t = toJSON v in t
|
||||
|
||||
instance FromJSONKey ClusterSettingsKey where
|
||||
fromJSONKey = FromJSONKeyTextParser $ parseJSON . String
|
||||
|
||||
instance PersistField ClusterSettingsKey where
|
||||
toPersistValue = PersistText . toPathPiece
|
||||
fromPersistValue (PersistText t) = maybe (Left $ "Could not parse " <> t) Right $ fromPathPiece t
|
||||
fromPersistValue _other = Left "Expecting PersistText"
|
||||
|
||||
instance PersistFieldSql ClusterSettingsKey where
|
||||
sqlType _ = SqlString
|
||||
|
||||
instance ToHttpApiData ClusterSettingsKey where
|
||||
toUrlPiece = toPathPiece
|
||||
instance FromHttpApiData ClusterSettingsKey where
|
||||
parseUrlPiece = maybe (Left "Could not parse url piece") Right . fromPathPiece
|
||||
|
||||
|
||||
class (ToJSON (ClusterSettingValue key), FromJSON (ClusterSettingValue key)) => ClusterSetting (key :: ClusterSettingsKey) where
|
||||
type ClusterSettingValue key :: *
|
||||
initClusterSetting :: forall m p. MonadIO m => p key -> m (ClusterSettingValue key)
|
||||
knownClusterSetting :: forall p. p key -> ClusterSettingsKey
|
||||
|
||||
|
||||
instance ClusterSetting 'ClusterCryptoIDKey where
|
||||
type ClusterSettingValue 'ClusterCryptoIDKey = CryptoIDKey
|
||||
initClusterSetting _ = CryptoID.genKey
|
||||
knownClusterSetting _ = ClusterCryptoIDKey
|
||||
|
||||
instance ToJSON CryptoIDKey where
|
||||
toJSON = Aeson.String . decodeUtf8 . Base64.encode . toStrict . Binary.encode
|
||||
|
||||
instance FromJSON CryptoIDKey where
|
||||
parseJSON = Aeson.withText "CryptoIDKey" $ \t -> do
|
||||
bytes <- either fail (return . fromStrict) . Base64.decode $ encodeUtf8 t
|
||||
case Binary.decodeOrFail bytes of
|
||||
Left (_, _, err) -> fail err
|
||||
Right (bs, _, ret)
|
||||
| null bs -> return ret
|
||||
| otherwise -> fail $ show (length bs) ++ " extra bytes"
|
||||
|
||||
|
||||
instance ClusterSetting 'ClusterClientSessionKey where
|
||||
type ClusterSettingValue 'ClusterClientSessionKey = ClientSession.Key
|
||||
initClusterSetting _ = liftIO $ view _2 <$> ClientSession.randomKey
|
||||
knownClusterSetting _ = ClusterClientSessionKey
|
||||
|
||||
instance ToJSON ClientSession.Key where
|
||||
toJSON = Aeson.String . decodeUtf8 . Base64.encode . Serialize.encode
|
||||
|
||||
instance FromJSON ClientSession.Key where
|
||||
parseJSON = Aeson.withText "Key" $ \t -> do
|
||||
bytes <- either fail return . Base64.decode $ encodeUtf8 t
|
||||
either fail return $ Serialize.decode bytes
|
||||
|
||||
|
||||
instance ClusterSetting 'ClusterErrorMessageKey where
|
||||
type ClusterSettingValue 'ClusterErrorMessageKey = SecretBox.Key
|
||||
initClusterSetting _ = liftIO $ SecretBox.newKey
|
||||
knownClusterSetting _ = ClusterErrorMessageKey
|
||||
|
||||
instance ToJSON SecretBox.Key where
|
||||
toJSON = Aeson.String . decodeUtf8 . Base64.encode . Saltine.encode
|
||||
|
||||
instance FromJSON SecretBox.Key where
|
||||
parseJSON = Aeson.withText "Key" $ \t -> do
|
||||
bytes <- either fail return . Base64.decode $ encodeUtf8 t
|
||||
maybe (fail "Could not parse key") return $ Saltine.decode bytes
|
||||
@ -1,19 +1,24 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module Utils.TH where
|
||||
-- Common Utility Functions that require TemplateHaskell
|
||||
|
||||
-- import Data.Char
|
||||
|
||||
import Prelude
|
||||
import ClassyPrelude.Yesod
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Datatype
|
||||
-- import Control.Monad
|
||||
-- import Control.Monad.Trans.Class
|
||||
-- import Control.Monad.Trans.Maybe
|
||||
-- import Control.Monad.Trans.Except
|
||||
|
||||
import Data.List ((!!), foldl)
|
||||
|
||||
------------
|
||||
-- Tuples --
|
||||
------------
|
||||
@ -45,7 +50,7 @@ altFun perm = lamE pat rhs
|
||||
where pat = map varP $ fn:xs
|
||||
rhs = foldl appE (varE fn) $ map varE ps
|
||||
-- rhs = appE (varE fn) (varE $ xs!!1)
|
||||
mx = maximum perm
|
||||
mx = maximum $ impureNonNull perm
|
||||
xs = [ mkName $ "x" ++ show j | j <- [1..mx] ]
|
||||
ps = [ xs !! (j-1) | j <- perm ]
|
||||
fn = mkName "fn"
|
||||
@ -78,3 +83,62 @@ deriveSimpleWith cls fun strOp ty = do
|
||||
in return $ Clause pats body []
|
||||
genClause _ = fail "deriveShowTheme: constructors not allowed to have arguments"
|
||||
|
||||
embedRenderMessage :: Name -- ^ Foundation type
|
||||
-> Name -- ^ Type to embed into message type
|
||||
-> (Text -> Text) -- ^ Mangle constructor names
|
||||
-> DecsQ
|
||||
-- ^ @embedRenderMessage ''Foundation ''MessageType mangle@ declares a
|
||||
-- `RenderMessage Foundation MessageType` instance expecting the default
|
||||
-- message-datatype (@FoundationMessage@) to contain one constructor for each
|
||||
-- constructor of @MessageType@, taking the same arguments:
|
||||
--
|
||||
-- > data NewMessage = NewMessageOne | NewMessageTwo
|
||||
-- > data FoundationMessage = MsgOne | MsgTwo
|
||||
-- >
|
||||
-- > -- embedRenderMessage ''Foundation ''NewMessage (drop 2 . splitCamel)
|
||||
-- > instance RenderMessage Foundation NewMessage where
|
||||
-- > renderMessage f ls = renderMessage f ls . \case
|
||||
-- > NewMessageOne -> MsgOne
|
||||
-- > NewMessageTwo -> MsgTwo
|
||||
embedRenderMessage f inner mangle = do
|
||||
DatatypeInfo{..} <- reifyDatatype inner
|
||||
let
|
||||
matches :: [MatchQ]
|
||||
matches = flip map datatypeCons $ \ConstructorInfo{..} -> do
|
||||
vars <- forM constructorFields $ \_ -> newName "x"
|
||||
let body = foldl (\e v -> e `appE` varE v) (conE . mkName . unpack $ "Msg" <> mangle (pack $ nameBase constructorName)) vars
|
||||
match (conP constructorName $ map varP vars) (normalB body) []
|
||||
|
||||
f' <- newName "f"
|
||||
ls <- newName "ls"
|
||||
|
||||
pure <$> instanceD (cxt []) [t|RenderMessage $(conT f) $(conT inner)|]
|
||||
[ funD 'renderMessage
|
||||
[ clause [varP f', varP ls] (normalB $ [e|renderMessage $(varE f') $(varE ls) . $(lamCaseE matches)|]) []
|
||||
]
|
||||
]
|
||||
|
||||
embedRenderMessageVariant :: Name -- ^ Foundation Type
|
||||
-> Name -- ^ Name of newtype
|
||||
-> (Text -> Text) -- ^ Mangle constructor names
|
||||
-> DecsQ
|
||||
embedRenderMessageVariant f newT mangle = do
|
||||
[ConstructorInfo{ constructorName = newtypeName, constructorFields = [ ConT newtypeInner ] }] <- datatypeCons <$> reifyDatatype newT
|
||||
DatatypeInfo{..} <- reifyDatatype newtypeInner
|
||||
|
||||
let
|
||||
matches :: [MatchQ]
|
||||
matches = flip map datatypeCons $ \ConstructorInfo{..} -> do
|
||||
vars <- forM constructorFields $ \_ -> newName "x"
|
||||
let body = foldl (\e v -> e `appE` varE v) (conE . mkName . unpack $ "Msg" <> mangle (pack $ nameBase constructorName)) vars
|
||||
match (conP newtypeName [conP constructorName $ map varP vars]) (normalB body) []
|
||||
|
||||
f' <- newName "f"
|
||||
ls <- newName "ls"
|
||||
|
||||
pure <$> instanceD (cxt []) [t|RenderMessage $(conT f) $(conT newT)|]
|
||||
[ funD 'renderMessage
|
||||
[ clause [varP f', varP ls] (normalB $ [e|renderMessage $(varE f') $(varE ls) . $(lamCaseE matches)|]) []
|
||||
]
|
||||
]
|
||||
|
||||
|
||||
@ -7,7 +7,7 @@ in haskell.lib.buildStackProject {
|
||||
inherit ghc;
|
||||
name = "stackenv";
|
||||
buildInputs = (with pkgs;
|
||||
[ postgresql zlib openldap cyrus_sasl.dev
|
||||
[ postgresql zlib openldap cyrus_sasl.dev libsodium
|
||||
]) ++ (with haskellPackages;
|
||||
[ yesod-bin
|
||||
]);
|
||||
|
||||
@ -36,4 +36,6 @@ extra-deps:
|
||||
|
||||
- persistent-2.7.3.1
|
||||
|
||||
- saltine-0.1.0.1
|
||||
|
||||
resolver: lts-10.5
|
||||
|
||||
@ -14,13 +14,11 @@
|
||||
|
||||
<div .main__content-body>
|
||||
|
||||
<h1>
|
||||
<!-- $maybe back <- lastMaybe parents
|
||||
$maybe headline <- contentHeadline
|
||||
<h1>
|
||||
<!-- $maybe back <- lastMaybe parents
|
||||
<a .breadcrumbs__link href="@{fst back}">#{snd back} -->
|
||||
$maybe headline <- contentHeadline
|
||||
^{headline}
|
||||
$nothing
|
||||
HEADLINE MISSING!
|
||||
|
||||
<!-- prime page actions -->
|
||||
^{pageactionprime}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user