fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX into sheet-type

Browse Source
This commit is contained in:
SJost 2018-10-31 09:45:32 +01:00
commit db18b4bdba
87 changed files with 631 additions and 885 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitignore vendored
View File

@ -1,8 +1,6 @@
dist*
static/tmp/
static/combined/
client_session_key.aes
cryptoid_key.bf
*.hi
*.o
*.sqlite3

7
config/settings.yml
View File

@ -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,11 @@ 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
database:
user: "_env:PGUSER:uniworx"
@ -86,5 +88,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"

25
messages/uniworx/de.msg
View File

@ -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,25 @@ 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.
ErrMsgCiphertext: Verschlüsselte Fehlermeldung
ErrMsgCiphertextTooShort: Verschlüsselte Daten zu kurz um valide zu sein
ErrMsgInvalidBase64 base64Err@String: Verschlüsselte Daten nicht korrekt base64url-kodiert: #{base64Err}
ErrMsgCouldNotDecodeNonce: Konnte secretbox-nonce nicht dekodieren
ErrMsgCouldNotOpenSecretbox: Konnte libsodium-secretbox nicht öffnen (Verschlüsselte Daten sind nicht authentisch)
ErrMsgCouldNotDecodePlaintext utf8Err@Text: Konnte Klartext nicht UTF8-dekodieren: #{utf8Err}
ErrMsgHeading: Fehlermeldung entschlüsseln

6
models
View File

@ -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

51
package.yaml
View File

@ -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,55 @@ dependencies:
- postgresql-simple
- word24
- mmorph
- clientsession
other-extensions:
- GeneralizedNewtypeDeriving
- IncoherentInstances
- OverloadedLists
- UndecidableInstances
default-extensions:
- OverloadedStrings
- PartialTypeSignatures
- ScopedTypeVariables
- TemplateHaskell
- QuasiQuotes
- CPP
- TypeSynonymInstances
- KindSignatures
- ConstraintKinds
- ViewPatterns
- TypeOperators
- TupleSections
- TypeFamilies
- GADTs
- StandaloneDeriving
- RecordWildCards
- RankNTypes
- PatternGuards
- PatternSynonyms
- ParallelListComp
- NumDecimals
- MultiWayIf
- NamedFieldPuns
- NoImplicitPrelude
- LambdaCase
- MultiParamTypeClasses
- FlexibleContexts
- FlexibleInstances
- FunctionalDependencies
- EmptyDataDecls
- ExistentialQuantification
- DefaultSignatures
- DeriveDataTypeable
- DeriveGeneric
- DeriveLift
- DeriveFunctor
- DerivingStrategies
- DataKinds
- BinaryLiterals
- PolyKinds
# The library contains all of our application code. The executable
# defined below is just a thin wrapper.

1
routes
View File

@ -36,6 +36,7 @@
/admin/test AdminTestR GET POST
/admin/user/#CryptoUUIDUser AdminUserR GET
/admin/user/#CryptoUUIDUser/hijack AdminHijackUserR POST
/admin/errMsg AdminErrMsgR GET POST
/info VersionR GET !free
/help HelpR GET POST !free

55
src/Application.hs
View File

@ -1,12 +1,5 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Application
( getApplicationDev, getAppDevSettings
, appMain
@ -67,6 +60,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 +104,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 +118,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 +143,36 @@ 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 <- clusterSetting (Proxy :: Proxy 'ClusterErrorMessageKey) `runSqlPool` sqlPool
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 <> ": " <> pack str
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

8
src/Auth/Dummy.hs
View File

@ -1,11 +1,3 @@
{-# LANGUAGE NoImplicitPrelude
, RecordWildCards
, TemplateHaskell
, FlexibleContexts
, TypeFamilies
, OverloadedStrings
#-}
module Auth.Dummy
( dummyLogin
, DummyMessage(..)

11
src/Auth/LDAP.hs
View File

@ -1,14 +1,3 @@
{-# LANGUAGE RecordWildCards
, OverloadedStrings
, TemplateHaskell
, ViewPatterns
, TypeFamilies
, FlexibleContexts
, FlexibleInstances
, NoImplicitPrelude
, ScopedTypeVariables
#-}
module Auth.LDAP
( campusLogin
, CampusUserException(..)

10
src/Auth/PWHash.hs
View File

@ -1,13 +1,3 @@
{-# LANGUAGE NoImplicitPrelude
, QuasiQuotes
, TemplateHaskell
, ViewPatterns
, RecordWildCards
, OverloadedStrings
, FlexibleContexts
, TypeFamilies
#-}
module Auth.PWHash
( hashLogin
, PWHashMessage(..)

9
src/Cron.hs
View File

@ -1,12 +1,3 @@
{-# LANGUAGE NoImplicitPrelude
, RecordWildCards
, PatternGuards
, ViewPatterns
, DeriveFunctor
, TemplateHaskell
, NamedFieldPuns
#-}
module Cron
( CronNextMatch(..)
, nextCronMatch

5
src/Cron/Types.hs
View File

@ -1,8 +1,3 @@
{-# LANGUAGE NoImplicitPrelude
, TemplateHaskell
, DuplicateRecordFields
#-}
module Cron.Types
( Cron(..), Crontab
, CronMatch(..)

8
src/CryptoID.hs
View File

@ -1,11 +1,3 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
{-# LANGUAGE RecordWildCards, ViewPatterns, PatternGuards #-}
{-# LANGUAGE PatternSynonyms #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module CryptoID

4
src/CryptoID/TH.hs
View File

@ -1,7 +1,3 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
module CryptoID.TH where
import ClassyPrelude

7
src/Data/CaseInsensitive/Instances.hs
View File

@ -1,11 +1,8 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.CaseInsensitive.Instances
() where
(
) where
import ClassyPrelude.Yesod

3
src/Data/Universe/Instances/Reverse/Hashable.hs
View File

@ -1,6 +1,3 @@
{-# LANGUAGE NoImplicitPrelude
, ScopedTypeVariables
#-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Universe.Instances.Reverse.Hashable

3
src/Data/Universe/Instances/Reverse/JSON.hs
View File

@ -1,6 +1,3 @@
{-# LANGUAGE NoImplicitPrelude
, ScopedTypeVariables
#-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Universe.Instances.Reverse.JSON

328
src/Foundation.hs
View File

@ -1,17 +1,4 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternGuards, MultiWayIf #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleInstances, UndecidableInstances, FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
module Foundation where
@ -20,6 +7,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 +85,9 @@ 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
instance DisplayAble b => DisplayAble (E.CryptoID a b) where
display = display . ciphertext
@ -127,6 +119,8 @@ data UniWorX = UniWorX
, appCryptoIDKey :: CryptoIDKey
, appInstanceID :: InstanceId
, appJobCtl :: [TMChan JobCtl]
, appErrorMsgKey :: SecretBox.Key
, appSessionKey :: ClientSession.Key
}
type SMTPPool = Pool SMTPConnection
@ -197,14 +191,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 +202,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 +217,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 +534,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 +588,52 @@ 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
canDecrypt <- (== Authorized) <$> evalAccess AdminErrMsgR True
shouldEncrypt <- getsYesod $ appEncryptErrors . appSettings
errKey <- getsYesod appErrorMsgKey
if
| shouldEncrypt
, not canDecrypt -> do
nonce <- liftIO SecretBox.newNonce
let ciphertext = SecretBox.secretbox errKey nonce . Lazy.ByteString.toStrict $ encode plaintextJson
encoded = decodeUtf8 . Base64.encode $ Saltine.encode nonce <> ciphertext
formatted = Text.intercalate "\n" $ Text.chunksOf 76 encoded
[whamlet|
<p>_{MsgErrorResponseEncrypted}
<pre .errMsg>
#{formatted}
|]
| otherwise -> plaintext
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 +680,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
@ -949,8 +960,8 @@ pageActions (HomeR) =
-- , menuItemAccessCallback' = return True
-- }
-- ,
NavbarAside $ MenuItem
{ menuItemLabel = "AdminDemo"
PageActionPrime $ MenuItem
{ menuItemLabel = "Admin-Demo"
, menuItemIcon = Just "screwdriver"
, menuItemRoute = AdminTestR
, menuItemModal = False
@ -963,6 +974,13 @@ pageActions (HomeR) =
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, PageActionPrime $ MenuItem
{ menuItemLabel = "Fehlermeldung entschlüsseln"
, menuItemIcon = Nothing
, menuItemRoute = AdminErrMsgR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
]
pageActions (ProfileR) =
[ PageActionPrime $ MenuItem
@ -1210,6 +1228,8 @@ pageHeading (AdminTestR)
= Just $ [whamlet|Internal Code Demonstration Page|]
pageHeading (AdminUserR _)
= Just $ [whamlet|User Display for Admin|]
pageHeading (AdminErrMsgR)
= Just $ i18nHeading MsgErrMsgHeading
pageHeading (VersionR)
= Just $ i18nHeading MsgImpressumHeading
pageHeading (HelpR)

56
src/Handler/Admin.hs
View File

@ -1,20 +1,22 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
module Handler.Admin where
import Import
import Handler.Utils
import Jobs
import qualified Data.ByteString as BS
import qualified Crypto.Saltine.Internal.ByteSizes as Saltine
import qualified Data.ByteString.Base64.URL as Base64
import Crypto.Saltine.Core.SecretBox (secretboxOpen)
import qualified Crypto.Saltine.Class as Saltine
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Char (isSpace)
import Control.Monad.Trans.Except
-- import Data.Time
-- import qualified Data.Text as T
-- import Data.Function ((&))
@ -105,3 +107,35 @@ getAdminUserR uuid = do
<h2>Admin Page for User ^{nameWidget userDisplayName userSurname}
|]
getAdminErrMsgR, postAdminErrMsgR :: Handler Html
getAdminErrMsgR = postAdminErrMsgR
postAdminErrMsgR = do
errKey <- getsYesod appErrorMsgKey
((ctResult, ctView), ctEncoding) <- runFormPost . renderAForm FormStandard $
(unTextarea <$> areq textareaField (fslpI MsgErrMsgCiphertext "Ciphertext") Nothing)
<* submitButton
plaintext <- formResultMaybe ctResult $ \(encodeUtf8 . Text.filter (not . isSpace) -> inputBS) ->
exceptT (\err -> Nothing <$ addMessageI Error err) (return . Just) $ do
ciphertext <- either (throwE . MsgErrMsgInvalidBase64) return $ Base64.decode inputBS
unless (BS.length ciphertext >= Saltine.secretBoxNonce + Saltine.secretBoxMac) $
throwE MsgErrMsgCiphertextTooShort
let (nonceBS, secretbox) = BS.splitAt Saltine.secretBoxNonce ciphertext
nonce <- maybe (throwE MsgErrMsgCouldNotDecodeNonce) return $ Saltine.decode nonceBS
plainBS <- maybe (throwE MsgErrMsgCouldNotOpenSecretbox) return $ secretboxOpen errKey nonce secretbox
either (throwE . MsgErrMsgCouldNotDecodePlaintext . tshow) return $ Text.decodeUtf8' plainBS
defaultLayout $
[whamlet|
$maybe t <- plaintext
<pre style="white-space:pre-wrap; font-family:monospace">
#{t}
<form action=@{AdminErrMsgR} method=post enctype=#{ctEncoding}>
^{ctView}
|]

5
src/Handler/Common.hs
View File

@ -1,8 +1,3 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
-- | Common handler functions.
module Handler.Common where

17
src/Handler/Corrections.hs
View File

@ -1,20 +1,3 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE MultiWayIf, LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiWayIf #-}
module Handler.Corrections where
import Import

15
src/Handler/Course.hs
View File

@ -1,18 +1,3 @@
{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
module Handler.Course where
import Import hiding (catMaybes)

16
src/Handler/CryptoIDDispatch.hs
View File

@ -1,23 +1,9 @@
{-# LANGUAGE NoImplicitPrelude
, DataKinds
, KindSignatures
, TypeFamilies
, FlexibleInstances
, TypeOperators
, RankNTypes
, PolyKinds
, RecordWildCards
, MultiParamTypeClasses
, ScopedTypeVariables
, ViewPatterns
#-}
module Handler.CryptoIDDispatch
( getCryptoUUIDDispatchR
, getCryptoFileNameDispatchR
) where
import Import hiding (Proxy)
import Import
import Data.Proxy

17
src/Handler/Home.hs
View File

@ -1,16 +1,3 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE IncoherentInstances #-} -- why is this needed? Instance for "display deadline" ought to be clear
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PartialTypeSignatures #-}
module Handler.Home where
import Import
@ -279,10 +266,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

14
src/Handler/Profile.hs
View File

@ -1,17 +1,3 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE MultiWayIf, LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
module Handler.Profile where
import Import

15
src/Handler/School.hs
View File

@ -1,18 +1,3 @@
{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
module Handler.School where
import Import

17
src/Handler/Sheet.hs
View File

@ -1,20 +1,3 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE MultiWayIf, LambdaCase #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NamedFieldPuns #-}
module Handler.Sheet where
import Import

35
src/Handler/Submission.hs
View File

@ -1,21 +1,3 @@
{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE ParallelListComp #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE MultiWayIf #-}
module Handler.Submission where
import Import hiding (joinPath)
@ -314,14 +296,15 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
, dbtProj = return . dbrOutput
, dbtStyle = def
, dbtIdent = "files" :: Text
, dbtSorting = [ ( "path"
, SortColumn $ \((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) -> E.coalesce [f1 E.?. FileTitle, f2 E.?. FileTitle]
)
, ( "time"
, SortColumn $ \((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) -> (E.unsafeSqlFunction "GREATEST" ([f1 E.?. FileModified, f2 E.?. FileModified] :: [E.SqlExpr (E.Value (Maybe UTCTime))]) :: E.SqlExpr (E.Value (Maybe UTCTime)))
)
]
, dbtFilter = []
, dbtSorting = Map.fromList
[ ( "path"
, SortColumn $ \((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) -> E.coalesce [f1 E.?. FileTitle, f2 E.?. FileTitle]
)
, ( "time"
, SortColumn $ \((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) -> (E.unsafeSqlFunction "GREATEST" ([f1 E.?. FileModified, f2 E.?. FileModified] :: [E.SqlExpr (E.Value (Maybe UTCTime))]) :: E.SqlExpr (E.Value (Maybe UTCTime)))
)
]
, dbtFilter = Map.empty
}
mFileTable <- traverse (fmap snd . dbTable def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid

14
src/Handler/SystemMessage.hs
View File

@ -1,17 +1,3 @@
{-# LANGUAGE NoImplicitPrelude
, RecordWildCards
, TemplateHaskell
, NamedFieldPuns
, RecordWildCards
, OverloadedStrings
, TypeFamilies
, ViewPatterns
, FlexibleContexts
, LambdaCase
, MultiParamTypeClasses
, QuasiQuotes
#-}
module Handler.SystemMessage where
import Import

63
src/Handler/Term.hs
View File

@ -1,19 +1,8 @@
{-# LANGUAGE NoImplicitPrelude
, OverloadedStrings
, OverloadedLists
, RecordWildCards
, TemplateHaskell
, QuasiQuotes
, MultiParamTypeClasses
, TypeFamilies
, FlexibleContexts
, PartialTypeSignatures
#-}
module Handler.Term where
import Import
import Handler.Utils
import qualified Data.Map as Map
-- import qualified Data.Text as T
import Yesod.Form.Bootstrap3
@ -111,30 +100,32 @@ getTermShowR = do
{ dbtSQLQuery = termData
, dbtColonnade = colonnadeTerms
, dbtProj = return . dbrOutput
, dbtSorting = [ ( "start"
, SortColumn $ \term -> term E.^. TermStart
)
, ( "end"
, SortColumn $ \term -> term E.^. TermEnd
)
, ( "lecture-start"
, SortColumn $ \term -> term E.^. TermLectureStart
)
, ( "lecture-end"
, SortColumn $ \term -> term E.^. TermLectureEnd
)
]
, dbtFilter = [ ( "active"
, FilterColumn $ \term -> (term E.^. TermActive :: E.SqlExpr (E.Value Bool))
)
, ( "course"
, FilterColumn $ \term csh -> case csh of -- FilterColumn-Lambdas are
[] -> E.val True :: E.SqlExpr (E.Value Bool)
cshs -> E.exists . E.from $ \course -> do
E.where_ $ course E.^. CourseTerm E.==. term E.^. TermId
E.&&. course E.^. CourseShorthand `E.in_` E.valList cshs
)
]
, dbtSorting = Map.fromList
[ ( "start"
, SortColumn $ \term -> term E.^. TermStart
)
, ( "end"
, SortColumn $ \term -> term E.^. TermEnd
)
, ( "lecture-start"
, SortColumn $ \term -> term E.^. TermLectureStart
)
, ( "lecture-end"
, SortColumn $ \term -> term E.^. TermLectureEnd
)
]
, dbtFilter = Map.fromList
[ ( "active"
, FilterColumn $ \term -> (term E.^. TermActive :: E.SqlExpr (E.Value Bool))
)
, ( "course"
, FilterColumn $ \term csh -> case csh of -- FilterColumn-Lambdas are
[] -> E.val True :: E.SqlExpr (E.Value Bool)
cshs -> E.exists . E.from $ \course -> do
E.where_ $ course E.^. CourseTerm E.==. term E.^. TermId
E.&&. course E.^. CourseShorthand `E.in_` E.valList cshs
)
]
, dbtStyle = def
, dbtIdent = "terms" :: Text
}

8
src/Handler/Users.hs
View File

@ -1,11 +1,3 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
module Handler.Users where
import Import

7
src/Handler/Utils.hs
View File

@ -1,10 +1,3 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
module Handler.Utils
( module Handler.Utils
) where

7
src/Handler/Utils/DateTime.hs
View File

@ -1,10 +1,3 @@
{-# LANGUAGE NoImplicitPrelude
, TemplateHaskell
, OverloadedStrings
, RecordWildCards
, TypeFamilies
#-}
module Handler.Utils.DateTime
( utcToLocalTime
, localTimeToUTC, TZ.LocalToUTCResult(..)

14
src/Handler/Utils/Form.hs
View File

@ -1,17 +1,3 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase #-}
module Handler.Utils.Form
( module Handler.Utils.Form
, module Utils.Form

2
src/Handler/Utils/Form/Types.hs
View File

@ -1,5 +1,3 @@
{-# LANGUAGE NoImplicitPrelude #-}
module Handler.Utils.Form.Types where
import Import

8
src/Handler/Utils/Mail.hs
View File

@ -1,11 +1,3 @@
{-# LANGUAGE NoImplicitPrelude
, NamedFieldPuns
, TypeFamilies
, FlexibleContexts
, ViewPatterns
, LambdaCase
#-}
module Handler.Utils.Mail
( addRecipientsDB
, userMailT

12
src/Handler/Utils/Rating.hs
View File

@ -1,16 +1,4 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
module Handler.Utils.Rating
( Rating(..), Rating'(..)

10
src/Handler/Utils/Sheet.hs
View File

@ -1,13 +1,3 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
module Handler.Utils.Sheet where
import Import

4
src/Handler/Utils/StudyFeatures.hs
View File

@ -1,7 +1,3 @@
{-# LANGUAGE NoImplicitPrelude
, RecordWildCards
#-}
module Handler.Utils.StudyFeatures
( parseStudyFeatures
) where

16
src/Handler/Utils/Submission.hs
View File

@ -1,19 +1,3 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiWayIf #-}
module Handler.Utils.Submission
( AssignSubmissionException(..)
, assignSubmissions

7
src/Handler/Utils/Submission/TH.hs
View File

@ -1,10 +1,3 @@
{-# LANGUAGE NoImplicitPrelude
, TemplateHaskell
, ViewPatterns
, OverloadedStrings
, StandaloneDeriving
, DeriveLift
#-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Handler.Utils.Submission.TH

5
src/Handler/Utils/Table.hs
View File

@ -1,8 +1,3 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeFamilies #-}
module Handler.Utils.Table where
-- General Utilities for Tables

7
src/Handler/Utils/Table/Cells.hs
View File

@ -1,10 +1,3 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
module Handler.Utils.Table.Cells where
import Import

22
src/Handler/Utils/Table/Pagination.hs
View File

@ -1,23 +1,3 @@
{-# LANGUAGE NoImplicitPrelude
, ExistentialQuantification
, RecordWildCards
, NamedFieldPuns
, OverloadedStrings
, TemplateHaskell
, QuasiQuotes
, LambdaCase
, ViewPatterns
, FlexibleContexts
, FlexibleInstances
, MultiParamTypeClasses
, TypeFamilies
, ScopedTypeVariables
, TupleSections
, RankNTypes
, MultiWayIf
, FunctionalDependencies
#-}
module Handler.Utils.Table.Pagination
( SortColumn(..), SortDirection(..)
, FilterColumn(..), IsFilterColumn
@ -47,7 +27,7 @@ module Handler.Utils.Table.Pagination
import Handler.Utils.Table.Pagination.Types
import Utils.Lens.TH
import Import hiding (Proxy(..))
import Import
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect,unsafeSqlValue)
import qualified Database.Esqueleto.Internal.Language as E (From)

6
src/Handler/Utils/Table/Pagination/Types.hs
View File

@ -1,9 +1,3 @@
{-# LANGUAGE NoImplicitPrelude
, ExistentialQuantification
, RankNTypes
, RecordWildCards
#-}
module Handler.Utils.Table.Pagination.Types where
import Import hiding (singleton)

2
src/Handler/Utils/Templates.hs
View File

@ -1,5 +1,3 @@
{-# LANGUAGE NoImplicitPrelude, TemplateHaskell, QuasiQuotes #-}
module Handler.Utils.Templates where
import Data.Either (isLeft)

4
src/Handler/Utils/Zip.hs
View File

@ -1,7 +1,3 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- This concerns zipEntrySize in produceZip
{-# OPTIONS_GHC -fno-warn-orphans #-}

3
src/Import/NoFoundation.hs
View File

@ -1,10 +1,9 @@
{-# LANGUAGE CPP #-}
module Import.NoFoundation
( module Import
, MForm
) where
import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm)
import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy)
import Model as Import
import Model.Types.JSON as Import
import Model.Migration as Import

17
src/Jobs.hs
View File

@ -1,29 +1,14 @@
{-# LANGUAGE NoImplicitPrelude
, RecordWildCards
, TemplateHaskell
, OverloadedStrings
, FlexibleContexts
, ViewPatterns
, TypeFamilies
, DeriveGeneric
, DeriveDataTypeable
, QuasiQuotes
, NamedFieldPuns
, MultiWayIf
#-}
module Jobs
( module Types
, module Jobs.Queue
, handleJobs
) where
import Import hiding (Proxy)
import Import
import Jobs.Types as Types hiding (JobCtl(JobCtlQueue))
import Jobs.Types (JobCtl(JobCtlQueue))
import Jobs.Queue
import Jobs.TH
import Jobs.Crontab
import Data.Conduit.TMChan

8
src/Jobs/Crontab.hs
View File

@ -1,11 +1,3 @@
{-# LANGUAGE NoImplicitPrelude
, RecordWildCards
, FlexibleContexts
, MultiWayIf
, NamedFieldPuns
, TypeFamilies
#-}
module Jobs.Crontab
( determineCrontab
) where

6
src/Jobs/Handler/HelpRequest.hs
View File

@ -1,9 +1,3 @@
{-# LANGUAGE NoImplicitPrelude
, TemplateHaskell
, RecordWildCards
, OverloadedStrings
#-}
module Jobs.Handler.HelpRequest
( dispatchJobHelpRequest
) where

5
src/Jobs/Handler/QueueNotification.hs
View File

@ -1,8 +1,3 @@
{-# LANGUAGE NoImplicitPrelude
, RecordWildCards
, NamedFieldPuns
#-}
module Jobs.Handler.QueueNotification
( dispatchJobQueueNotification
) where

5
src/Jobs/Handler/SendNotification.hs
View File

@ -1,14 +1,9 @@
{-# LANGUAGE NoImplicitPrelude
, TemplateHaskell
#-}
module Jobs.Handler.SendNotification
( dispatchJobSendNotification
) where
import Import
import Jobs.TH
import Jobs.Types

7
src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs
View File

@ -1,10 +1,3 @@
{-# LANGUAGE NoImplicitPrelude
, RecordWildCards
, NamedFieldPuns
, TemplateHaskell
, OverloadedStrings
#-}
module Jobs.Handler.SendNotification.CorrectionsAssigned
( dispatchNotificationCorrectionsAssigned
) where

7
src/Jobs/Handler/SendNotification/SheetActive.hs
View File

@ -1,10 +1,3 @@
{-# LANGUAGE NoImplicitPrelude
, RecordWildCards
, NamedFieldPuns
, TemplateHaskell
, OverloadedStrings
#-}
module Jobs.Handler.SendNotification.SheetActive
( dispatchNotificationSheetActive
) where

9
src/Jobs/Handler/SendNotification/SheetInactive.hs
View File

@ -1,10 +1,3 @@
{-# LANGUAGE NoImplicitPrelude
, RecordWildCards
, NamedFieldPuns
, TemplateHaskell
, OverloadedStrings
#-}
module Jobs.Handler.SendNotification.SheetInactive
( dispatchNotificationSheetSoonInactive
, dispatchNotificationSheetInactive
@ -55,4 +48,4 @@ dispatchNotificationSheetInactive nSheet jRecipient = userMailT jRecipient $ do
addAlternatives $ do
let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
providePreferredAlternative ($(ihamletFile "templates/mail/sheetInactive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

7
src/Jobs/Handler/SendNotification/SubmissionRated.hs
View File

@ -1,10 +1,3 @@
{-# LANGUAGE NoImplicitPrelude
, RecordWildCards
, NamedFieldPuns
, TemplateHaskell
, OverloadedStrings
#-}
module Jobs.Handler.SendNotification.SubmissionRated
( dispatchNotificationSubmissionRated
) where

6
src/Jobs/Handler/SendTestEmail.hs
View File

@ -1,9 +1,3 @@
{-# LANGUAGE NoImplicitPrelude
, RecordWildCards
, NamedFieldPuns
, QuasiQuotes
#-}
module Jobs.Handler.SendTestEmail
( dispatchJobSendTestEmail
) where

3
src/Jobs/Handler/SetLogSettings.hs
View File

@ -1,6 +1,3 @@
{-# LANGUAGE NoImplicitPrelude
#-}
module Jobs.Handler.SetLogSettings
( dispatchJobSetLogSettings
) where

4
src/Jobs/Queue.hs
View File

@ -1,7 +1,3 @@
{-# LANGUAGE NoImplicitPrelude
, TypeFamilies
#-}
module Jobs.Queue
( writeJobCtl, writeJobCtlBlock
, queueJob, queueJob'

29
src/Jobs/TH.hs
View File

@ -1,29 +0,0 @@
{-# LANGUAGE NoImplicitPrelude
, TemplateHaskell
, QuasiQuotes
, RecordWildCards
#-}
module Jobs.TH
( dispatchTH
) where
import ClassyPrelude
import Language.Haskell.TH
import Language.Haskell.TH.Datatype
import Data.List (foldl)
dispatchTH :: Name -- ^ Datatype to pattern match
-> ExpQ
dispatchTH dType = do
DatatypeInfo{..} <- reifyDatatype dType
let
matches = map mkMatch datatypeCons
mkMatch ConstructorInfo{..} = do
pats <- forM constructorFields $ \_ -> newName "x"
let fName = mkName $ "dispatch" <> nameBase constructorName
match (conP constructorName $ map varP pats) (normalB $ foldl (\e pat -> e `appE` varE pat) (varE fName) pats) []
lamCaseE matches

6
src/Jobs/Types.hs
View File

@ -1,9 +1,3 @@
{-# LANGUAGE TemplateHaskell
, NoImplicitPrelude
, DeriveGeneric
, DeriveDataTypeable
#-}
module Jobs.Types
( Job(..), Notification(..)
, JobCtl(..)

19
src/Mail.hs
View File

@ -1,22 +1,5 @@
{-# LANGUAGE NoImplicitPrelude
, GeneralizedNewtypeDeriving
, DerivingStrategies
, FlexibleInstances
, MultiParamTypeClasses
{-# LANGUAGE GeneralizedNewtypeDeriving
, UndecidableInstances
, DeriveGeneric
, TemplateHaskell
, OverloadedStrings
, RecordWildCards
, FlexibleContexts
, TypeFamilies
, ViewPatterns
, NamedFieldPuns
, MultiWayIf
, QuasiQuotes
, RankNTypes
, ScopedTypeVariables
, DeriveDataTypeable
#-}
module Mail

20
src/Model.hs
View File

@ -1,17 +1,4 @@
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
module Model
( module Model
@ -33,6 +20,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
@ -43,12 +31,6 @@ share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll
-- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only
deriving instance Eq (Unique Course)
data PWEntry = PWEntry
{ pwUser :: User
, pwHash :: Text
} deriving (Show)
$(deriveJSON defaultOptions ''PWEntry)
submissionRatingDone :: Submission -> Bool
submissionRatingDone Submission{..} = isJust submissionRatingTime

8
src/Model/Migration.hs
View File

@ -1,11 +1,3 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
{-# LANGUAGE TypeFamilies, FlexibleInstances #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Model.Migration
( migrateAll
) where

7
src/Model/Migration/Version.hs
View File

@ -1,10 +1,3 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveLift, DeriveGeneric, DeriveDataTypeable #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Model.Migration.Version

16
src/Model/Types.hs
View File

@ -1,16 +1,6 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE MultiWayIf #-}
{-- # LANGUAGE ExistentialQuantification #-} -- for DA type
{-# LANGUAGE GeneralizedNewtypeDeriving
, UndecidableInstances
#-}
{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text)
module Model.Types

4
src/Model/Types/JSON.hs
View File

@ -1,7 +1,3 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
module Model.Types.JSON
( derivePersistFieldJSON
) where

6
src/Model/Types/Wordlist.hs
View File

@ -1,9 +1,3 @@
{-# LANGUAGE NoImplicitPrelude
, TemplateHaskell
, ViewPatterns
, OverloadedStrings
#-}
module Model.Types.Wordlist (wordlist) where
import ClassyPrelude hiding (lift)

35
src/Settings.hs
View File

@ -1,25 +1,21 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Settings are centralized, as much as possible, into this file. This
-- includes database connection settings, static file locations, etc.
-- 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 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 +53,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 +88,7 @@ data AppSettings = AppSettings
, appNotificationRateLimit :: NominalDiffTime
, appNotificationCollateDelay :: NominalDiffTime
, appNotificationExpiration :: NominalDiffTime
, appSessionTimeout :: NominalDiffTime
, appInitialLogSettings :: LogSettings
@ -104,12 +102,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 +262,6 @@ deriveFromJSON
''Address
instance FromJSON AppSettings where
parseJSON = withObject "AppSettings" $ \o -> do
let defaultDev =
@ -298,19 +295,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 {..}

126
src/Settings/Cluster.hs Normal file
View File

@ -0,0 +1,126 @@
{-# 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

3
src/Settings/StaticFiles.hs
View File

@ -1,6 +1,3 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Settings.StaticFiles where
import Settings (appStaticDir, compileTimeAppSettings)

9
src/Utils.hs
View File

@ -1,12 +1,3 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
{-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-}
{-# LANGUAGE QuasiQuotes, TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} -- Monad FormResult
module Utils

5
src/Utils/DB.hs
View File

@ -1,8 +1,3 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-}
{-# LANGUAGE QuasiQuotes #-}
module Utils.DB where
import ClassyPrelude.Yesod

13
src/Utils/DateTime.hs
View File

@ -1,15 +1,4 @@
{-# LANGUAGE NoImplicitPrelude
, TemplateHaskell
, QuasiQuotes
, StandaloneDeriving
, DerivingStrategies
, DeriveLift
, DeriveDataTypeable
, DeriveGeneric
, GeneralizedNewtypeDeriving
, OverloadedStrings
, FlexibleInstances
#-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Utils.DateTime

24
src/Utils/Form.hs
View File

@ -1,18 +1,3 @@
{-# LANGUAGE NoImplicitPrelude
, TemplateHaskell
, ViewPatterns
, OverloadedStrings
, QuasiQuotes
, TemplateHaskell
, MultiParamTypeClasses
, TypeFamilies
, FlexibleContexts
, NamedFieldPuns
, ScopedTypeVariables
, MultiWayIf
, RecordWildCards
#-}
module Utils.Form where
import ClassyPrelude.Yesod hiding (addMessage)
@ -284,6 +269,9 @@ reorderField optList = Field{..}
---------------------
formResult :: MonadHandler m => FormResult a -> (a -> m ()) -> m ()
formResult (FormFailure errs) _ = forM_ errs $ addMessage Error . toHtml
formResult FormMissing _ = return ()
formResult (FormSuccess res) f = f res
formResult res f = void . formResultMaybe res $ \x -> Nothing <$ f x
formResultMaybe :: MonadHandler m => FormResult a -> (a -> m (Maybe b)) -> m (Maybe b)
formResultMaybe (FormFailure errs) _ = Nothing <$ forM_ errs (addMessage Error . toHtml)
formResultMaybe FormMissing _ = return Nothing
formResultMaybe (FormSuccess res) f = f res

4
src/Utils/Lang.hs
View File

@ -1,7 +1,3 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Utils.Lang where
import ClassyPrelude.Yesod

5
src/Utils/Lens.hs
View File

@ -1,8 +1,3 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
module Utils.Lens ( module Utils.Lens ) where
import Import.NoFoundation

7
src/Utils/Message.hs
View File

@ -1,10 +1,3 @@
{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveLift #-}
module Utils.Message
( MessageClass(..)
, addMessage, addMessageI, addMessageIHamlet, addMessageFile

3
src/Utils/PathPiece.hs
View File

@ -1,6 +1,3 @@
{-# LANGUAGE NoImplicitPrelude
#-}
module Utils.PathPiece
( finiteFromPathPiece
, nullaryToPathPiece

8
src/Utils/Sql.hs
View File

@ -1,11 +1,3 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NumDecimals #-}
{-# LANGUAGE FlexibleContexts #-}
module Utils.Sql
( setSerializable
) where

4
src/Utils/SystemMessage.hs
View File

@ -1,7 +1,3 @@
{-# LANGUAGE NoImplicitPrelude
, RecordWildCards
#-}
module Utils.SystemMessage where
import Import.NoFoundation

83
src/Utils/TH.hs
View File

@ -1,19 +1,18 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}
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 +44,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 +77,75 @@ 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)|]) []
]
]
dispatchTH :: Name -- ^ Datatype to pattern match
-> ExpQ
-- ^ Produces a lambda-case-expression matching all constructors of the named datatype and calling a function (named after the constructor prefixed with @dispatch@) on the fields of each constructor
dispatchTH dType = do
DatatypeInfo{..} <- reifyDatatype dType
let
matches = map mkMatch datatypeCons
mkMatch ConstructorInfo{..} = do
pats <- forM constructorFields $ \_ -> newName "x"
let fName = mkName $ "dispatch" <> nameBase constructorName
match (conP constructorName $ map varP pats) (normalB $ foldl (\e pat -> e `appE` varE pat) (varE fName) pats) []
lamCaseE matches

2
stack.nix
View File

@ -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
]);

2
stack.yaml
View File

@ -36,4 +36,6 @@ extra-deps:
- persistent-2.7.3.1
- saltine-0.1.0.1
resolver: lts-10.5

8
templates/default-layout.hamlet
View File

@ -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}

5
templates/mail/support.hamlet
View File

@ -28,5 +28,10 @@ $newline never
<dd>#{lang}
<dt>Zeit
<dd>#{rtime}
$maybe referer <- jReferer
<dt>Referer
<dd>
<a href=#{referer} style="font-family: monospace">
#{referer}
<p style="white-space: pre-wrap; font-family: monospace">
#{jHelpRequest}