refactor: split foundation & llvm
BREAKING CHANGE: split foundation
This commit is contained in:
Gregor Kleen
parent
eceb6a6c45
commit
c68a01d7ae
@ -32,13 +32,13 @@ npm install:
|
||||
before_script: &npm
|
||||
- rm -rvf /etc/apt/sources.list /etc/apt/sources.list.d
|
||||
- install -v -T -m 0644 ${APT_SOURCES_LIST} /etc/apt/sources.list
|
||||
- apt-get update -y
|
||||
- apt update -y
|
||||
- npm install -g n
|
||||
- n 13.5.0
|
||||
- export PATH="${N_PREFIX}/bin:$PATH"
|
||||
- npm install -g npm
|
||||
- hash -r
|
||||
- apt-get -y install openssh-client exiftool
|
||||
- apt -y install openssh-client exiftool
|
||||
- install -v -m 0700 -d ~/.ssh
|
||||
- install -v -T -m 0644 ${SSH_KNOWN_HOSTS} ~/.ssh/known_hosts
|
||||
- install -v -T -m 0400 ${SSH_DEPLOY_KEY} ~/.ssh/deploy && echo "IdentityFile ~/.ssh/deploy" >> ~/.ssh/config;
|
||||
@ -93,9 +93,9 @@ yesod:build:dev:
|
||||
before_script: &haskell
|
||||
- rm -rvf /etc/apt/sources.list /etc/apt/sources.list.d
|
||||
- install -v -T -m 0644 ${APT_SOURCES_LIST} /etc/apt/sources.list
|
||||
- apt-get update -y
|
||||
- apt-get install -y --no-install-recommends locales-all
|
||||
- apt-get install openssh-client -y
|
||||
- curl https://apt.llvm.org/llvm-snapshot.gpg.key | apt-key add -
|
||||
- apt update -y
|
||||
- apt install -y --no-install-recommends locales-all openssh-client clang-9 lldb-9 lld-9 clangd-9
|
||||
- install -v -m 0700 -d ~/.ssh
|
||||
- install -v -T -m 0644 ${SSH_KNOWN_HOSTS} ~/.ssh/known_hosts
|
||||
- install -v -T -m 0400 ${SSH_DEPLOY_KEY} ~/.ssh/deploy && echo "IdentityFile ~/.ssh/deploy" >> ~/.ssh/config;
|
||||
@ -143,13 +143,13 @@ frontend:test:
|
||||
before_script:
|
||||
- rm -rvf /etc/apt/sources.list /etc/apt/sources.list.d
|
||||
- install -v -T -m 0644 ${APT_SOURCES_LIST} /etc/apt/sources.list
|
||||
- apt-get update -y
|
||||
- apt update -y
|
||||
- npm install -g n
|
||||
- n 13.5.0
|
||||
- export PATH="${N_PREFIX}/bin:$PATH"
|
||||
- npm install -g npm
|
||||
- hash -r
|
||||
- apt-get install -y --no-install-recommends chromium-browser
|
||||
- apt install -y --no-install-recommends chromium-browser
|
||||
dependencies:
|
||||
- npm install
|
||||
retry: 2
|
||||
@ -243,8 +243,8 @@ deploy:uniworx3:
|
||||
before_script:
|
||||
- rm -rvf /etc/apt/sources.list /etc/apt/sources.list.d
|
||||
- install -v -T -m 0644 ${APT_SOURCES_LIST} /etc/apt/sources.list
|
||||
- apt-get update -y
|
||||
- apt-get install -y --no-install-recommends openssh-client
|
||||
- apt update -y
|
||||
- apt install -y --no-install-recommends openssh-client
|
||||
- install -v -m 0700 -d ~/.ssh
|
||||
- install -v -T -m 0644 ${SSH_KNOWN_HOSTS} ~/.ssh/known_hosts
|
||||
- install -v -T -m 0400 ${SSH_PRIVATE_KEY_UNIWORX3} ~/.ssh/uniworx3; echo "IdentityFile ~/.ssh/uniworx3" >> ~/.ssh/config;
|
||||
|
||||
40
package.yaml
40
package.yaml
@ -63,7 +63,6 @@ dependencies:
|
||||
- cryptoids-class
|
||||
- binary
|
||||
- binary-instances
|
||||
- cereal
|
||||
- mtl
|
||||
- esqueleto >=3.1.0
|
||||
- mime-types
|
||||
@ -210,6 +209,8 @@ default-extensions:
|
||||
- TypeFamilyDependencies
|
||||
- QuantifiedConstraints
|
||||
- EmptyDataDeriving
|
||||
- StandaloneKindSignatures
|
||||
- NoStarIsType
|
||||
|
||||
ghc-options:
|
||||
- -Wall
|
||||
@ -229,42 +230,41 @@ when:
|
||||
ghc-options:
|
||||
- -Werror
|
||||
- -fwarn-tabs
|
||||
- condition: flag(dev)
|
||||
then:
|
||||
ghc-options:
|
||||
- -O0
|
||||
- -ddump-splices
|
||||
- -ddump-to-file
|
||||
cpp-options: -DDEVELOPMENT
|
||||
ghc-prof-options:
|
||||
- -fprof-auto
|
||||
else:
|
||||
ghc-options:
|
||||
- -O -fllvm
|
||||
|
||||
# The library contains all of our application code. The executable
|
||||
# defined below is just a thin wrapper.
|
||||
library:
|
||||
source-dirs: src
|
||||
when:
|
||||
- condition: flag(dev)
|
||||
then:
|
||||
ghc-options:
|
||||
- -O0
|
||||
- -ddump-splices
|
||||
- -ddump-to-file
|
||||
cpp-options: -DDEVELOPMENT
|
||||
ghc-prof-options:
|
||||
- -fprof-auto
|
||||
else:
|
||||
ghc-options:
|
||||
- -O2
|
||||
|
||||
# Runnable executable for our application
|
||||
executables:
|
||||
uniworx:
|
||||
main: main.hs
|
||||
source-dirs: app
|
||||
ghc-options: -threaded -rtsopts "-with-rtsopts=-N -T -xn"
|
||||
dependencies:
|
||||
- uniworx
|
||||
when:
|
||||
- condition: flag(library-only)
|
||||
buildable: false
|
||||
ghc-options:
|
||||
- -threaded -rtsopts "-with-rtsopts=-N -T -xn"
|
||||
uniworxdb:
|
||||
main: Database.hs
|
||||
ghc-options:
|
||||
- -main-is Database
|
||||
- -threaded
|
||||
- -rtsopts "-with-rtsopts=-N -T"
|
||||
- -threaded -rtsopts "-with-rtsopts=-N -T -xn"
|
||||
source-dirs: test
|
||||
dependencies:
|
||||
- uniworx
|
||||
@ -277,8 +277,7 @@ executables:
|
||||
main: Load.hs
|
||||
ghc-options:
|
||||
- -main-is Load
|
||||
- -threaded
|
||||
- -rtsopts "-with-rtsopts=-N -T -xn"
|
||||
- -threaded -rtsopts "-with-rtsopts=-N -T -xn"
|
||||
source-dirs: load
|
||||
dependencies:
|
||||
- uniworx
|
||||
@ -312,8 +311,7 @@ tests:
|
||||
- yesod-persistent
|
||||
ghc-options:
|
||||
- -fno-warn-orphans
|
||||
- -threaded
|
||||
- -rtsopts "-with-rtsopts=-N -xn"
|
||||
- -threaded -rtsopts "-with-rtsopts=-N -T -xn"
|
||||
hlint:
|
||||
main: Hlint.hs
|
||||
other-modules: []
|
||||
|
||||
22
src/Database/Persist/Sql/Types/Instances.hs
Normal file
22
src/Database/Persist/Sql/Types/Instances.hs
Normal file
@ -0,0 +1,22 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Database.Persist.Sql.Types.Instances
|
||||
(
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
|
||||
import Database.Persist.Sql
|
||||
|
||||
|
||||
instance BackendCompatible SqlWriteBackend SqlWriteBackend where
|
||||
projectBackend = id
|
||||
|
||||
instance BackendCompatible SqlReadBackend SqlReadBackend where
|
||||
projectBackend = id
|
||||
|
||||
instance BackendCompatible SqlReadBackend SqlBackend where
|
||||
projectBackend = SqlReadBackend
|
||||
|
||||
instance BackendCompatible SqlWriteBackend SqlBackend where
|
||||
projectBackend = SqlWriteBackend
|
||||
5291
src/Foundation.hs
5291
src/Foundation.hs
File diff suppressed because it is too large
Load Diff
1475
src/Foundation/Authorization.hs
Normal file
1475
src/Foundation/Authorization.hs
Normal file
File diff suppressed because it is too large
Load Diff
46
src/Foundation/DB.hs
Normal file
46
src/Foundation/DB.hs
Normal file
@ -0,0 +1,46 @@
|
||||
module Foundation.DB
|
||||
( runDBRead
|
||||
, runSqlPoolRetry
|
||||
) where
|
||||
|
||||
import Import.NoFoundation hiding (runDB, getDBRunner)
|
||||
|
||||
import Foundation.Type
|
||||
|
||||
import qualified Control.Retry as Retry
|
||||
import GHC.IO.Exception (IOErrorType(OtherError))
|
||||
|
||||
import Database.Persist.Sql (runSqlPool, SqlReadBackend(..))
|
||||
|
||||
|
||||
runSqlPoolRetry :: forall m a backend.
|
||||
( MonadUnliftIO m, BackendCompatible SqlBackend backend
|
||||
, MonadLogger m, MonadMask m
|
||||
)
|
||||
=> ReaderT backend m a
|
||||
-> Pool backend
|
||||
-> m a
|
||||
runSqlPoolRetry action pool = do
|
||||
let policy = Retry.fullJitterBackoff 1e3 & Retry.limitRetriesByCumulativeDelay 10e6
|
||||
handlers = Retry.skipAsyncExceptions `snoc` Retry.logRetries suggestRetry logRetry
|
||||
where suggestRetry :: IOException -> m Bool
|
||||
suggestRetry ioExc = return $
|
||||
ioeGetErrorType ioExc == OtherError
|
||||
&& ioeGetLocation ioExc == "libpq"
|
||||
logRetry :: forall e.
|
||||
Exception e
|
||||
=> Bool -- ^ Will retry
|
||||
-> e
|
||||
-> Retry.RetryStatus
|
||||
-> m ()
|
||||
logRetry shouldRetry@False err status = $logErrorS "runSqlPoolRetry" . pack $ Retry.defaultLogMsg shouldRetry err status
|
||||
logRetry shouldRetry@True err status = $logWarnS "runSqlPoolRetry" . pack $ Retry.defaultLogMsg shouldRetry err status
|
||||
|
||||
Retry.recovering policy handlers $ \Retry.RetryStatus{..} -> do
|
||||
$logDebugS "runSqlPoolRetry" $ "rsIterNumber = " <> tshow rsIterNumber
|
||||
runSqlPool action pool
|
||||
|
||||
runDBRead :: ReaderT SqlReadBackend (HandlerFor UniWorX) a -> (HandlerFor UniWorX) a
|
||||
runDBRead action = do
|
||||
$logDebugS "YesodPersist" "runDBRead"
|
||||
runSqlPoolRetry (withReaderT SqlReadBackend action) . appConnPool =<< getYesod
|
||||
@ -1,11 +1,12 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module Foundation.I18n
|
||||
( appLanguages
|
||||
( appLanguages, appLanguagesOpts
|
||||
, UniWorXMessage(..)
|
||||
, ShortTermIdentifier(..)
|
||||
, MsgLanguage(..)
|
||||
, ShortSex(..)
|
||||
, ShortWeekDay(..)
|
||||
, SheetTypeHeader(..)
|
||||
, SheetArchiveFileTypeDirectory(..)
|
||||
, ShortStudyDegree(..)
|
||||
@ -34,16 +35,17 @@ import qualified Data.Text as Text
|
||||
|
||||
import Utils.Form
|
||||
|
||||
import GHC.Exts (IsList(..))
|
||||
import qualified GHC.Exts (IsList(..))
|
||||
|
||||
import Yesod.Form.I18n.German
|
||||
import Yesod.Form.I18n.English
|
||||
|
||||
import qualified Data.Foldable as F
|
||||
import qualified Data.Char as Char
|
||||
import Text.Unidecode (unidecode)
|
||||
import Data.Text.Lens (packed)
|
||||
|
||||
import Data.List ((!!))
|
||||
|
||||
|
||||
appLanguages :: NonEmpty Lang
|
||||
appLanguages = "de-de-formal" :| ["en-eu"]
|
||||
@ -183,6 +185,20 @@ instance RenderMessage UniWorX MsgLanguage where
|
||||
where
|
||||
mr = renderMessage foundation $ lang : filter (/= lang) ls
|
||||
|
||||
appLanguagesOpts :: ( MonadHandler m
|
||||
, RenderMessage (HandlerSite m) MsgLanguage
|
||||
) => m (OptionList Lang)
|
||||
-- ^ Authoritive list of supported Languages
|
||||
appLanguagesOpts = do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
let mkOption l = Option
|
||||
{ optionDisplay = mr $ MsgLanguage l
|
||||
, optionInternalValue = l
|
||||
, optionExternalValue = l
|
||||
}
|
||||
langOptions = map mkOption $ toList appLanguages
|
||||
return $ mkOptionList langOptions
|
||||
|
||||
embedRenderMessage ''UniWorX ''MessageStatus ("Message" <>)
|
||||
embedRenderMessage ''UniWorX ''NotificationTrigger $ ("NotificationTrigger" <>) . concat . drop 1 . splitCamel
|
||||
embedRenderMessage ''UniWorX ''StudyFieldType id
|
||||
@ -364,6 +380,23 @@ instance RenderMessage UniWorX (ValueRequired UniWorX) where
|
||||
mr :: forall msg. RenderMessage UniWorX msg => msg -> Text
|
||||
mr = renderMessage foundation ls
|
||||
|
||||
instance RenderRoute UniWorX => RenderMessage UniWorX (UnsupportedAuthPredicate AuthTag (Route UniWorX)) where
|
||||
renderMessage f ls (UnsupportedAuthPredicate tag route) = mr . MsgUnsupportedAuthPredicate (mr tag) $ Text.intercalate "/" pieces
|
||||
where
|
||||
mr :: forall msg. RenderMessage UniWorX msg => msg -> Text
|
||||
mr = renderMessage f ls
|
||||
(pieces, _) = renderRoute route
|
||||
|
||||
instance RenderMessage UniWorX WeekDay where
|
||||
renderMessage _ ls wDay = pack . fst $ wDays (getTimeLocale' ls) !! (fromEnum wDay `mod` 7)
|
||||
|
||||
newtype ShortWeekDay = ShortWeekDay { longWeekDay :: WeekDay }
|
||||
|
||||
instance RenderMessage UniWorX ShortWeekDay where
|
||||
renderMessage _ ls (ShortWeekDay wDay) = pack . snd $ wDays (getTimeLocale' ls) !! (fromEnum wDay `mod` 7)
|
||||
|
||||
embedRenderMessage ''UniWorX ''ButtonSubmit id
|
||||
|
||||
|
||||
unRenderMessage' :: (Eq a, Finite a, RenderMessage master a) => (Text -> Text -> Bool) -> master -> Text -> [a]
|
||||
unRenderMessage' cmp foundation inp = nub $ do
|
||||
@ -371,7 +404,7 @@ unRenderMessage' cmp foundation inp = nub $ do
|
||||
x <- universeF
|
||||
guard $ renderMessage foundation (l : filter (/= l) appLanguages') x `cmp` inp
|
||||
return x
|
||||
where appLanguages' = F.toList appLanguages
|
||||
where appLanguages' = toList appLanguages
|
||||
|
||||
unRenderMessage :: (Eq a, Finite a, RenderMessage master a) => master -> Text -> [a]
|
||||
unRenderMessage = unRenderMessage' (==)
|
||||
@ -379,3 +412,7 @@ unRenderMessage = unRenderMessage' (==)
|
||||
unRenderMessageLenient :: (Eq a, Finite a, RenderMessage master a) => master -> Text -> [a]
|
||||
unRenderMessageLenient = unRenderMessage' cmp
|
||||
where cmp = (==) `on` mk . under packed (filter Char.isAlphaNum . concatMap unidecode)
|
||||
|
||||
|
||||
instance Default DateTimeFormatter where
|
||||
def = mkDateTimeFormatter (getTimeLocale' []) def appTZ
|
||||
|
||||
203
src/Foundation/Instances.hs
Normal file
203
src/Foundation/Instances.hs
Normal file
@ -0,0 +1,203 @@
|
||||
{-# LANGUAGE UndecidableInstances #-} -- for `MonadCrypto` and `MonadSecretBox`
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Foundation.Instances
|
||||
( ButtonClass(..), YesodPersistBackend, AuthId, MonadCryptoKey
|
||||
, unsafeHandler
|
||||
) where
|
||||
|
||||
import Import.NoFoundation
|
||||
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.List as List
|
||||
import Data.List (inits)
|
||||
|
||||
import qualified Yesod.Core.Unsafe as Unsafe
|
||||
import qualified Yesod.Auth.Message as Auth
|
||||
|
||||
import Utils.Form
|
||||
import Auth.LDAP
|
||||
import Auth.PWHash
|
||||
import Auth.Dummy
|
||||
|
||||
import qualified Foundation.Yesod.Session as UniWorX
|
||||
import qualified Foundation.Yesod.Middleware as UniWorX
|
||||
import qualified Foundation.Yesod.ErrorHandler as UniWorX
|
||||
import qualified Foundation.Yesod.StaticContent as UniWorX
|
||||
import qualified Foundation.Yesod.Persist as UniWorX
|
||||
import qualified Foundation.Yesod.Auth as UniWorX
|
||||
|
||||
import Foundation.SiteLayout
|
||||
import Foundation.Type
|
||||
import Foundation.I18n
|
||||
import Foundation.Authorization
|
||||
import Foundation.Yesod.Auth hiding (authenticate)
|
||||
import Foundation.Routes
|
||||
import Foundation.DB
|
||||
|
||||
import Network.Wai.Parse (lbsBackEnd)
|
||||
|
||||
import Control.Monad.Writer.Class (MonadWriter(..))
|
||||
import UnliftIO.Pool (withResource)
|
||||
|
||||
|
||||
data instance ButtonClass UniWorX
|
||||
= BCIsButton
|
||||
| BCDefault
|
||||
| BCPrimary
|
||||
| BCSuccess
|
||||
| BCInfo
|
||||
| BCWarning
|
||||
| BCDanger
|
||||
| BCLink
|
||||
| BCMassInputAdd | BCMassInputDelete
|
||||
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
instance PathPiece (ButtonClass UniWorX) where
|
||||
toPathPiece BCIsButton = "btn"
|
||||
toPathPiece bClass = ("btn-" <>) . camelToPathPiece' 1 $ tshow bClass
|
||||
fromPathPiece = flip List.lookup $ map (toPathPiece &&& id) universeF
|
||||
|
||||
instance Button UniWorX ButtonSubmit where
|
||||
btnClasses BtnSubmit = [BCIsButton, BCPrimary]
|
||||
|
||||
|
||||
|
||||
-- Please see the documentation for the Yesod typeclass. There are a number
|
||||
-- of settings which can be configured by overriding methods here.
|
||||
instance Yesod UniWorX where
|
||||
-- Controls the base of generated URLs. For more information on modifying,
|
||||
-- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot
|
||||
approot = ApprootRequest $ \app req ->
|
||||
case app ^. _appRoot of
|
||||
Nothing -> getApprootText guessApproot app req
|
||||
Just root -> root
|
||||
|
||||
makeSessionBackend = UniWorX.makeSessionBackend
|
||||
|
||||
maximumContentLength app _ = app ^. _appMaximumContentLength
|
||||
|
||||
-- Yesod Middleware allows you to run code before and after each handler function.
|
||||
-- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks.
|
||||
-- Some users may also want to add the defaultCsrfMiddleware, which:
|
||||
-- a) Sets a cookie with a CSRF token in it.
|
||||
-- b) Validates that incoming write requests include that token in either a header or POST parameter.
|
||||
-- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
|
||||
-- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package.
|
||||
yesodMiddleware = UniWorX.yesodMiddleware
|
||||
|
||||
-- Since we implement `errorHandler` ourselves we don't need `defaultMessageWidget`
|
||||
defaultMessageWidget _title _body = error "defaultMessageWidget: undefined"
|
||||
|
||||
errorHandler = UniWorX.errorHandler
|
||||
|
||||
defaultLayout = siteLayout' Nothing
|
||||
|
||||
-- The page to be redirected to when authentication is required.
|
||||
authRoute _ = Just $ AuthR LoginR
|
||||
|
||||
isAuthorized = evalAccess
|
||||
|
||||
addStaticContent = UniWorX.addStaticContent
|
||||
|
||||
fileUpload _site _length = FileUploadMemory lbsBackEnd
|
||||
|
||||
-- What messages should be logged. The following includes all messages when
|
||||
-- in development, and warnings and errors in production.
|
||||
shouldLogIO app _source level = do
|
||||
LogSettings{..} <- readTVarIO $ appLogSettings app
|
||||
return $ logAll || level >= logMinimumLevel
|
||||
|
||||
makeLogger = readTVarIO . snd . appLogger
|
||||
|
||||
unsafeHandler :: UniWorX -> HandlerFor UniWorX a -> IO a
|
||||
unsafeHandler f h = do
|
||||
logger <- makeLogger f
|
||||
Unsafe.fakeHandlerGetLogger (const logger) f h
|
||||
|
||||
|
||||
-- How to run database actions.
|
||||
instance YesodPersist UniWorX where
|
||||
type YesodPersistBackend UniWorX = SqlBackend
|
||||
runDB = UniWorX.runDB
|
||||
|
||||
instance YesodPersistRunner UniWorX where
|
||||
getDBRunner = UniWorX.getDBRunner
|
||||
|
||||
|
||||
instance YesodAuth UniWorX where
|
||||
type AuthId UniWorX = UserId
|
||||
|
||||
-- Where to send a user after successful login
|
||||
loginDest _ = NewsR
|
||||
-- Where to send a user after logout
|
||||
logoutDest _ = NewsR
|
||||
-- Override the above two destinations when a Referer: header is present
|
||||
redirectToReferer _ = True
|
||||
|
||||
loginHandler = do
|
||||
toParent <- getRouteToParent
|
||||
liftHandler . defaultLayout $ do
|
||||
plugins <- getsYesod authPlugins
|
||||
$logDebugS "Auth" $ "Enabled plugins: " <> Text.intercalate ", " (map apName plugins)
|
||||
|
||||
setTitleI MsgLoginTitle
|
||||
$(widgetFile "login")
|
||||
|
||||
authenticate = UniWorX.authenticate
|
||||
|
||||
authPlugins UniWorX{ appSettings' = AppSettings{..}, appLdapPool } = catMaybes
|
||||
[ flip campusLogin campusUserFailoverMode <$> appLdapPool
|
||||
, Just . hashLogin $ pwHashAlgorithm appAuthPWHash
|
||||
, dummyLogin <$ guard appAuthDummyLogin
|
||||
]
|
||||
|
||||
authHttpManager = getsYesod appHttpManager
|
||||
|
||||
onLogin = liftHandler $ do
|
||||
mlang <- runDB $ updateUserLanguage Nothing
|
||||
app <- getYesod
|
||||
let mr | Just lang <- mlang = renderMessage app . map (Text.intercalate "-") . reverse . inits $ Text.splitOn "-" lang
|
||||
| otherwise = renderMessage app []
|
||||
addMessage Success . toHtml $ mr Auth.NowLoggedIn
|
||||
|
||||
onErrorHtml dest msg = do
|
||||
addMessage Error $ toHtml msg
|
||||
redirect dest
|
||||
|
||||
renderAuthMessage _ ls = case lang of
|
||||
("en" : _) -> Auth.englishMessage
|
||||
_other -> Auth.germanMessage
|
||||
where lang = Text.splitOn "-" $ selectLanguage' appLanguages ls
|
||||
|
||||
instance YesodAuthPersist UniWorX where
|
||||
getAuthEntity = liftHandler . runDBRead . get
|
||||
|
||||
|
||||
instance YesodMail UniWorX where
|
||||
defaultFromAddress = getsYesod $ view _appMailFrom
|
||||
mailObjectIdDomain = getsYesod $ view _appMailObjectDomain
|
||||
mailVerp = getsYesod $ view _appMailVerp
|
||||
mailDateTZ = return appTZ
|
||||
mailSmtp act = do
|
||||
pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool
|
||||
withResource pool act
|
||||
mailT ctx mail = defMailT ctx $ do
|
||||
void setMailObjectIdRandom
|
||||
setDateCurrent
|
||||
replaceMailHeader "Sender" . Just =<< getsYesod (view $ _appMailFrom . _addressEmail)
|
||||
|
||||
(mRes, smtpData) <- listen mail
|
||||
unless (view _MailSmtpDataSet smtpData)
|
||||
setMailSmtpData
|
||||
|
||||
return mRes
|
||||
|
||||
|
||||
instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where
|
||||
type MonadCryptoKey m = CryptoIDKey
|
||||
cryptoIDKey f = getsYesod appCryptoIDKey >>= f
|
||||
|
||||
instance {-# OVERLAPPING #-} (Monad m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadSecretBox m where
|
||||
secretBoxKey = getsYesod appSecretBoxKey
|
||||
2239
src/Foundation/Navigation.hs
Normal file
2239
src/Foundation/Navigation.hs
Normal file
File diff suppressed because it is too large
Load Diff
@ -21,8 +21,8 @@ import Foundation.Routes.Definitions
|
||||
-- http://www.yesodweb.com/book/scaffolding-and-the-site-template#scaffolding-and-the-site-template_foundation_and_application_modules
|
||||
--
|
||||
-- This function also generates the following type synonyms:
|
||||
-- type Handler x = HandlerT UniWorX IO x
|
||||
-- type Widget = WidgetT UniWorX IO ()
|
||||
-- type Handler x = HandlerFor UniWorX x
|
||||
-- type Widget = WidgetFor UniWorX ()
|
||||
mkYesodData "UniWorX" uniworxRoutes
|
||||
|
||||
deriving instance Generic CourseR
|
||||
|
||||
569
src/Foundation/SiteLayout.hs
Normal file
569
src/Foundation/SiteLayout.hs
Normal file
@ -0,0 +1,569 @@
|
||||
{-# LANGUAGE UndecidableInstances #-} -- for `MemcachedKeyFavourites`
|
||||
|
||||
module Foundation.SiteLayout
|
||||
( siteLayout', siteLayout
|
||||
, siteLayoutMsg', siteLayoutMsg
|
||||
, getSystemMessageState
|
||||
) where
|
||||
|
||||
import Import.NoFoundation hiding (embedFile)
|
||||
|
||||
import Foundation.Type
|
||||
import Foundation.Authorization
|
||||
import Foundation.Routes
|
||||
import Foundation.Navigation
|
||||
import Foundation.I18n
|
||||
import Foundation.DB
|
||||
|
||||
import Utils.SystemMessage
|
||||
import Utils.Form
|
||||
import Utils.Course
|
||||
import Utils.Metrics
|
||||
|
||||
import Handler.Utils.Routes
|
||||
import Handler.Utils.Memcached
|
||||
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import qualified Data.Conduit.Combinators as C
|
||||
|
||||
import Text.Cassius (cassiusFile)
|
||||
import Text.Hamlet (hamletFile)
|
||||
import Data.FileEmbed (embedFile)
|
||||
|
||||
|
||||
data MemcachedKeyFavourites
|
||||
= MemcachedKeyFavouriteQuickActions CourseId AuthContext (NonEmpty Lang)
|
||||
deriving (Generic, Typeable)
|
||||
|
||||
deriving instance Eq AuthContext => Eq MemcachedKeyFavourites
|
||||
deriving instance Read AuthContext => Read MemcachedKeyFavourites
|
||||
deriving instance Show AuthContext => Show MemcachedKeyFavourites
|
||||
deriving instance Hashable AuthContext => Hashable MemcachedKeyFavourites
|
||||
deriving instance Binary AuthContext => Binary MemcachedKeyFavourites
|
||||
|
||||
data MemcachedLimitKeyFavourites
|
||||
= MemcachedLimitKeyFavourites
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriving anyclass (Hashable, Binary)
|
||||
|
||||
|
||||
siteLayoutMsg :: (RenderMessage site msg, site ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), Button UniWorX ButtonSubmit) => msg -> WidgetFor UniWorX () -> HandlerFor UniWorX Html
|
||||
siteLayoutMsg = siteLayout . i18n
|
||||
|
||||
{-# DEPRECATED siteLayoutMsg' "Use siteLayoutMsg" #-}
|
||||
siteLayoutMsg' :: (RenderMessage site msg, site ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), Button UniWorX ButtonSubmit) => msg -> WidgetFor UniWorX () -> HandlerFor UniWorX Html
|
||||
siteLayoutMsg' = siteLayoutMsg
|
||||
|
||||
siteLayout :: ( BearerAuthSite UniWorX
|
||||
, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
|
||||
, Button UniWorX ButtonSubmit
|
||||
)
|
||||
=> WidgetFor UniWorX () -- ^ `pageHeading`
|
||||
-> WidgetFor UniWorX () -> HandlerFor UniWorX Html
|
||||
siteLayout = siteLayout' . Just
|
||||
|
||||
siteLayout' :: ( BearerAuthSite UniWorX
|
||||
, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
|
||||
, Button UniWorX ButtonSubmit
|
||||
)
|
||||
=> Maybe (WidgetFor UniWorX ()) -- ^ `pageHeading`
|
||||
-> WidgetFor UniWorX () -> HandlerFor UniWorX Html
|
||||
siteLayout' overrideHeading widget = do
|
||||
AppSettings { appUserDefaults = UserDefaultConf{..}, .. } <- getsYesod $ view appSettings
|
||||
|
||||
isModal <- hasCustomHeader HeaderIsModal
|
||||
|
||||
primaryLanguage <- unsafeHead . Text.splitOn "-" <$> selectLanguage appLanguages
|
||||
|
||||
mcurrentRoute <- getCurrentRoute
|
||||
let currentHandler = classifyHandler <$> mcurrentRoute
|
||||
|
||||
currentApproot' <- siteApproot <$> getYesod <*> (reqWaiRequest <$> getRequest)
|
||||
|
||||
-- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance.
|
||||
let
|
||||
breadcrumbs' mcRoute = do
|
||||
mr <- getMessageRender
|
||||
case mcRoute of
|
||||
Nothing -> return (mr MsgErrorResponseTitleNotFound, [])
|
||||
Just cRoute -> do
|
||||
(title, next) <- breadcrumb cRoute
|
||||
crumbs <- go [] next
|
||||
return (title, crumbs)
|
||||
where
|
||||
go crumbs Nothing = return crumbs
|
||||
go crumbs (Just cRoute) = do
|
||||
hasAccess <- hasReadAccessTo cRoute
|
||||
(title, next) <- breadcrumb cRoute
|
||||
go ((cRoute, title, hasAccess) : crumbs) next
|
||||
(title, parents) <- breadcrumbs' mcurrentRoute
|
||||
|
||||
-- let isParent :: Route UniWorX -> Bool
|
||||
-- isParent r = r == (fst parents)
|
||||
|
||||
isAuth <- isJust <$> maybeAuthId
|
||||
|
||||
now <- liftIO getCurrentTime
|
||||
|
||||
-- Lookup Favourites & Theme if possible
|
||||
(favourites', maxFavouriteTerms, currentTheme) <- do
|
||||
muid <- maybeAuthPair
|
||||
|
||||
favCourses'' <- runDBRead . E.select . E.from $ \(course `E.LeftOuterJoin` courseFavourite) -> do
|
||||
E.on $ E.just (course E.^. CourseId) E.==. courseFavourite E.?. CourseFavouriteCourse
|
||||
E.&&. courseFavourite E.?. CourseFavouriteUser E.==. E.val (view _1 <$> muid)
|
||||
|
||||
let isFavourite = E.not_ . E.isNothing $ courseFavourite E.?. CourseFavouriteId
|
||||
isCurrent
|
||||
| Just (CourseR tid ssh csh _) <- mcurrentRoute
|
||||
= course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
| otherwise
|
||||
= E.false
|
||||
notBlacklist = E.not_ . E.exists . E.from $ \courseNoFavourite ->
|
||||
E.where_ $ E.just (courseNoFavourite E.^. CourseNoFavouriteUser) E.==. E.val (view _1 <$> muid)
|
||||
E.&&. courseNoFavourite E.^. CourseNoFavouriteCourse E.==. course E.^. CourseId
|
||||
isParticipant = E.exists . E.from $ \participant ->
|
||||
E.where_ $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
|
||||
E.&&. E.just (participant E.^. CourseParticipantUser) E.==. E.val (view _1 <$> muid)
|
||||
E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
||||
isLecturer = E.exists . E.from $ \lecturer ->
|
||||
E.where_ $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
|
||||
E.&&. E.just (lecturer E.^. LecturerUser) E.==. E.val (view _1 <$> muid)
|
||||
isCorrector = E.exists . E.from $ \(corrector `E.InnerJoin` sheet) -> do
|
||||
E.on $ corrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
|
||||
E.&&. sheet E.^. SheetCourse E.==. course E.^. CourseId
|
||||
E.where_ $ E.just (corrector E.^. SheetCorrectorUser) E.==. E.val (view _1 <$> muid)
|
||||
isTutor = E.exists . E.from $ \(tutor `E.InnerJoin` tutorial) -> do
|
||||
E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
|
||||
E.&&. tutorial E.^. TutorialCourse E.==. course E.^. CourseId
|
||||
E.where_ $ E.just (tutor E.^. TutorUser) E.==. E.val (view _1 <$> muid)
|
||||
isAssociated = isParticipant E.||. isLecturer E.||. isCorrector E.||. isTutor
|
||||
courseVisible = courseIsVisible now course Nothing
|
||||
|
||||
reason = E.case_
|
||||
[ E.when_ isCurrent E.then_ . E.just $ E.val FavouriteCurrent
|
||||
, E.when_ isAssociated E.then_ . E.just $ E.val FavouriteParticipant
|
||||
] (E.else_ $ courseFavourite E.?. CourseFavouriteReason)
|
||||
|
||||
E.where_ $ ((isFavourite E.||. isAssociated) E.&&. notBlacklist) E.||. isCurrent
|
||||
|
||||
return (course, reason, courseVisible)
|
||||
|
||||
favCourses' <- forM favCourses'' $ \(course@(Entity _ Course{..}), reason, E.Value courseVisible) -> do
|
||||
mayView <- hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CShowR
|
||||
mayEdit <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR
|
||||
return (course, reason, courseVisible, mayView, mayEdit)
|
||||
|
||||
let favCourses = favCourses' & filter (\(_, _, _, mayView, _) -> mayView)
|
||||
|
||||
return ( favCourses
|
||||
, maybe userDefaultMaxFavouriteTerms userMaxFavouriteTerms $ view _2 <$> muid
|
||||
, maybe userDefaultTheme userTheme $ view _2 <$> muid
|
||||
)
|
||||
|
||||
let favouriteTerms :: [TermIdentifier]
|
||||
favouriteTerms = take maxFavouriteTerms . Set.toDescList $ foldMap (\(Entity _ Course{..}, _, _, _, _) -> Set.singleton $ unTermKey courseTerm) favourites'
|
||||
|
||||
favourites <- fmap catMaybes . forM favourites' $ \(Entity cId c@Course{..}, E.Value mFavourite, courseVisible, mayView, mayEdit)
|
||||
-> let courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR
|
||||
favouriteReason = fromMaybe FavouriteCurrent mFavourite
|
||||
in runMaybeT . guardOnM (unTermKey courseTerm `elem` favouriteTerms) . lift $ do
|
||||
ctx <- getAuthContext
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
langs <- selectLanguages appLanguages <$> languages
|
||||
let cK = MemcachedKeyFavouriteQuickActions cId ctx langs
|
||||
$logDebugS "FavouriteQuickActions" $ tshow cK <> " Checking..."
|
||||
items <- memcachedLimitedKeyTimeoutBy
|
||||
MemcachedLimitKeyFavourites appFavouritesQuickActionsBurstsize appFavouritesQuickActionsAvgInverseRate 1
|
||||
(Right <$> appFavouritesQuickActionsCacheTTL)
|
||||
appFavouritesQuickActionsTimeout
|
||||
cK
|
||||
cK
|
||||
. observeFavouritesQuickActionsDuration $ do
|
||||
$logDebugS "FavouriteQuickActions" $ tshow cK <> " Starting..."
|
||||
items' <- pageQuickActions NavQuickViewFavourite courseRoute
|
||||
items <- forM items' $ \n@NavLink{navLabel} -> (mr navLabel,) <$> toTextUrl n
|
||||
$logDebugS "FavouriteQuickActions" $ tshow cK <> " Done."
|
||||
return items
|
||||
$logDebugS "FavouriteQuickActions" $ tshow cK <> " returning " <> tshow (is _Just items)
|
||||
return (c, courseRoute, items, favouriteReason, courseVisible, mayView, mayEdit)
|
||||
|
||||
nav'' <- mconcat <$> sequence
|
||||
[ defaultLinks
|
||||
, maybe (return []) pageActions mcurrentRoute
|
||||
]
|
||||
nav' <- catMaybes <$> mapM (runMaybeT . navAccess) nav''
|
||||
nav <- forM nav' $ \n -> (n,,,) <$> newIdent <*> traverse toTextUrl (n ^? _navLink) <*> traverse (\nc -> (nc,, ) <$> newIdent <*> toTextUrl nc) (n ^. _navChildren)
|
||||
|
||||
mmsgs <- if
|
||||
| isModal -> return mempty
|
||||
| otherwise -> do
|
||||
applySystemMessages
|
||||
authTagPivots <- fromMaybe Set.empty <$> takeSessionJson SessionInactiveAuthTags
|
||||
forM_ authTagPivots $
|
||||
\authTag -> addMessageWidget Info $ msgModal [whamlet|_{MsgUnauthorizedDisabledTag authTag}|] (Left $ SomeRoute (AuthPredsR, catMaybes [(toPathPiece GetReferer, ) . toPathPiece <$> mcurrentRoute]))
|
||||
getMessages
|
||||
|
||||
-- (langFormView, langFormEnctype) <- generateFormPost $ identifyForm FIDLanguage langForm
|
||||
-- let langFormView' = wrapForm langFormView def
|
||||
-- { formAction = Just $ SomeRoute LangR
|
||||
-- , formSubmit = FormAutoSubmit
|
||||
-- , formEncoding = langFormEnctype
|
||||
-- }
|
||||
|
||||
let highlight :: HasRoute UniWorX url => url -> Bool
|
||||
-- ^ highlight last route in breadcrumbs, favorites taking priority
|
||||
highlight = (highR ==) . Just . urlRoute
|
||||
where crumbs = mcons mcurrentRoute $ view _1 <$> reverse parents
|
||||
navItems = map (view _2) favourites ++ toListOf (folded . typesUsing @NavChildren @NavLink . to urlRoute) nav
|
||||
highR = find (`elem` navItems) . uncurry (++) $ partition (`elem` map (view _2) favourites) crumbs
|
||||
highlightNav = (||) <$> navForceActive <*> highlight
|
||||
favouriteTermReason :: TermIdentifier -> FavouriteReason -> [(Course, Route UniWorX, Maybe [(Text, Text)], FavouriteReason, Bool, Bool, Bool)]
|
||||
favouriteTermReason tid favReason' = favourites
|
||||
& filter (\(Course{..}, _, _, favReason, _, _, _) -> unTermKey courseTerm == tid && favReason == favReason')
|
||||
& sortOn (\(Course{..}, _, _, _, _, _, _) -> courseName)
|
||||
|
||||
-- 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.
|
||||
|
||||
navWidget :: (Nav, Text, Maybe Text, [(NavLink, Text, Text)]) -> WidgetFor UniWorX ()
|
||||
navWidget (n, navIdent, navRoute', navChildren') = case n of
|
||||
NavHeader{ navLink = navLink@NavLink{..}, .. }
|
||||
| NavTypeLink{..} <- navType
|
||||
, navModal
|
||||
-> customModal Modal
|
||||
{ modalTriggerId = Just navIdent
|
||||
, modalId = Nothing
|
||||
, modalTrigger = \mroute ident -> case mroute of
|
||||
Just route -> $(widgetFile "widgets/navbar/item")
|
||||
Nothing -> error "navWidget with non-link modal"
|
||||
, modalContent = Left $ SomeRoute navLink
|
||||
}
|
||||
| NavTypeLink{} <- navType
|
||||
-> let route = navRoute'
|
||||
ident = navIdent
|
||||
in $(widgetFile "widgets/navbar/item")
|
||||
NavPageActionPrimary{ navLink = navLink@NavLink{..} }
|
||||
-> let pWidget
|
||||
| NavTypeLink{..} <- navType
|
||||
, navModal
|
||||
= customModal Modal
|
||||
{ modalTriggerId = Just navIdent
|
||||
, modalId = Nothing
|
||||
, modalTrigger = \mroute ident -> case mroute of
|
||||
Just route -> $(widgetFile "widgets/pageaction/primary")
|
||||
Nothing -> error "navWidget with non-link modal"
|
||||
, modalContent = Left $ SomeRoute navLink
|
||||
}
|
||||
| NavTypeLink{} <- navType
|
||||
= let route = navRoute'
|
||||
ident = navIdent
|
||||
in $(widgetFile "widgets/pageaction/primary")
|
||||
| otherwise
|
||||
= error "not implemented"
|
||||
sWidgets = navChildren'
|
||||
& map (\(l, i, r) -> navWidget (NavPageActionSecondary l, i, Just r, []))
|
||||
in $(widgetFile "widgets/pageaction/primary-wrapper")
|
||||
NavPageActionSecondary{ navLink = navLink@NavLink{..} }
|
||||
| NavTypeLink{..} <- navType
|
||||
, navModal
|
||||
-> customModal Modal
|
||||
{ modalTriggerId = Just navIdent
|
||||
, modalId = Nothing
|
||||
, modalTrigger = \mroute ident -> case mroute of
|
||||
Just route -> $(widgetFile "widgets/pageaction/secondary")
|
||||
Nothing -> error "navWidget with non-link modal"
|
||||
, modalContent = Left $ SomeRoute navLink
|
||||
}
|
||||
| NavTypeLink{} <- navType
|
||||
-> let route = navRoute'
|
||||
ident = navIdent
|
||||
in $(widgetFile "widgets/pageaction/secondary")
|
||||
NavHeaderContainer{..} -> $(widgetFile "widgets/navbar/container")
|
||||
NavFooter{ navLink = navLink@NavLink{..} }
|
||||
| NavTypeLink{..} <- navType
|
||||
, not navModal
|
||||
-> let route = navRoute'
|
||||
ident = navIdent
|
||||
in $(widgetFile "widgets/footer/link")
|
||||
_other -> error "not implemented"
|
||||
|
||||
navContainerItemWidget :: (Nav, Text, Maybe Text, [(NavLink, Text, Text)])
|
||||
-> (NavLink, Text, Text)
|
||||
-> WidgetFor UniWorX ()
|
||||
navContainerItemWidget (n, _navIdent, _navRoute', _navChildren') (iN@NavLink{..}, iNavIdent, iNavRoute) = case n of
|
||||
NavHeaderContainer{}
|
||||
| NavTypeLink{..} <- navType
|
||||
, navModal
|
||||
-> customModal Modal
|
||||
{ modalTriggerId = Just iNavIdent
|
||||
, modalId = Nothing
|
||||
, modalTrigger = \mroute ident -> case mroute of
|
||||
Just route -> $(widgetFile "widgets/navbar/navbar-container-item--link")
|
||||
Nothing -> error "navWidget with non-link modal"
|
||||
, modalContent = Left $ SomeRoute iN
|
||||
}
|
||||
| NavTypeLink{} <- navType
|
||||
-> let route = iNavRoute
|
||||
ident = iNavIdent
|
||||
in $(widgetFile "widgets/navbar/navbar-container-item--link")
|
||||
| NavTypeButton{..} <- navType -> do
|
||||
csrfToken <- reqToken <$> getRequest
|
||||
wrapForm $(widgetFile "widgets/navbar/navbar-container-item--button") def
|
||||
{ formMethod = navMethod
|
||||
, formSubmit = FormNoSubmit
|
||||
, formAction = Just $ SomeRoute iN
|
||||
}
|
||||
_other -> error "not implemented"
|
||||
|
||||
navbar :: WidgetFor UniWorX ()
|
||||
navbar = do
|
||||
$(widgetFile "widgets/navbar/navbar")
|
||||
forM_ (filter isNavHeaderContainer nav) $ \(_, containerIdent, _, _) ->
|
||||
toWidget $(cassiusFile "templates/widgets/navbar/container-radio.cassius")
|
||||
where isNavHeaderPrimary = has $ _1 . _navHeaderRole . only NavHeaderPrimary
|
||||
isNavHeaderSecondary = has $ _1 . _navHeaderRole . only NavHeaderSecondary
|
||||
asidenav :: WidgetFor UniWorX ()
|
||||
asidenav = $(widgetFile "widgets/asidenav/asidenav")
|
||||
where
|
||||
logo = preEscapedToMarkup $ decodeUtf8 $(embedFile "assets/lmu/logo.svg")
|
||||
footer :: WidgetFor UniWorX ()
|
||||
footer = $(widgetFile "widgets/footer/footer")
|
||||
where isNavFooter = has $ _1 . _NavFooter
|
||||
alerts :: WidgetFor UniWorX ()
|
||||
alerts = $(widgetFile "widgets/alerts/alerts")
|
||||
contentHeadline :: Maybe (WidgetFor UniWorX ())
|
||||
contentHeadline = overrideHeading <|> (pageHeading =<< mcurrentRoute)
|
||||
breadcrumbsWgt :: WidgetFor UniWorX ()
|
||||
breadcrumbsWgt = $(widgetFile "widgets/breadcrumbs/breadcrumbs")
|
||||
pageaction :: WidgetFor UniWorX ()
|
||||
pageaction = $(widgetFile "widgets/pageaction/pageaction")
|
||||
-- functions to determine if there are page-actions (primary or secondary)
|
||||
hasPageActions, hasSecondaryPageActions, hasPrimaryPageActions :: Bool
|
||||
hasPageActions = hasPrimaryPageActions || hasSecondaryPageActions
|
||||
hasSecondaryPageActions = has (folded . _1 . _NavPageActionSecondary) nav
|
||||
hasPrimaryPageActions = has (folded . _1 . _NavPageActionPrimary ) nav
|
||||
hasPrimarySubActions = has (folded . _1 . filtered (is _NavPageActionPrimary) . _navChildren . folded) nav
|
||||
contentRibbon :: Maybe (WidgetFor UniWorX ())
|
||||
contentRibbon = fmap toWidget appRibbon
|
||||
|
||||
isNavHeaderContainer = has $ _1 . _NavHeaderContainer
|
||||
isPageActionPrimary = has $ _1 . _NavPageActionPrimary
|
||||
isPageActionSecondary = has $ _1 . _NavPageActionSecondary
|
||||
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
let
|
||||
-- See Utils.Frontend.I18n and files in messages/frontend for message definitions
|
||||
frontendI18n = toJSON (mr :: FrontendMessage -> Text)
|
||||
frontendDatetimeLocale <- toJSON <$> selectLanguage frontendDatetimeLocales
|
||||
|
||||
pc <- widgetToPageContent $ do
|
||||
webpackLinks_main StaticR
|
||||
toWidget $(juliusFile "templates/i18n.julius")
|
||||
whenIsJust currentApproot' $ \currentApproot ->
|
||||
toWidget $(juliusFile "templates/approot.julius")
|
||||
whenIsJust mcurrentRoute $ \currentRoute' -> do
|
||||
currentRoute <- toTextUrl currentRoute'
|
||||
toWidget $(juliusFile "templates/current-route.julius")
|
||||
wellKnownHtmlLinks
|
||||
|
||||
$(widgetFile "default-layout")
|
||||
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
|
||||
|
||||
|
||||
getSystemMessageState :: (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => SystemMessageId -> m UserSystemMessageState
|
||||
getSystemMessageState smId = liftHandler $ do
|
||||
muid <- maybeAuthId
|
||||
reqSt <- $cachedHere getSystemMessageStateRequest
|
||||
dbSt <- $cachedHere $ maybe (return mempty) getDBSystemMessageState muid
|
||||
let MergeHashMap smSt = reqSt <> dbSt
|
||||
smSt' = MergeHashMap $ HashMap.filter (/= mempty) smSt
|
||||
when (smSt' /= reqSt) $
|
||||
setRegisteredCookieJson CookieSystemMessageState
|
||||
=<< ifoldMapM (\smId' v -> MergeHashMap <$> (HashMap.singleton <$> encrypt smId' <*> pure v :: HandlerFor UniWorX (HashMap CryptoUUIDSystemMessage _))) smSt'
|
||||
|
||||
return . fromMaybe mempty $ HashMap.lookup smId smSt
|
||||
where
|
||||
getSystemMessageStateRequest =
|
||||
(lookupRegisteredCookiesJson id CookieSystemMessageState :: HandlerFor UniWorX (MergeHashMap CryptoUUIDSystemMessage UserSystemMessageState))
|
||||
>>= ifoldMapM (\(cID :: CryptoUUIDSystemMessage) v -> MergeHashMap <$> (maybeT (return mempty) . catchMPlus (Proxy @CryptoIDError) $ HashMap.singleton <$> decrypt cID <*> pure v))
|
||||
getDBSystemMessageState uid = runDBRead . runConduit $ selectSource [ SystemMessageHiddenUser ==. uid ] [] .| C.foldMap foldSt
|
||||
where foldSt (Entity _ SystemMessageHidden{..})
|
||||
= MergeHashMap . HashMap.singleton systemMessageHiddenMessage $ mempty { userSystemMessageHidden = Just systemMessageHiddenTime }
|
||||
|
||||
applySystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), BearerAuthSite UniWorX) => m ()
|
||||
applySystemMessages = liftHandler . maybeT_ . catchMPlus (Proxy @CryptoIDError) $ do
|
||||
lift $ maybeAuthId >>= traverse_ syncSystemMessageHidden
|
||||
|
||||
cRoute <- lift getCurrentRoute
|
||||
guard $ cRoute /= Just NewsR
|
||||
|
||||
lift . runDBRead . runConduit $ selectSource [] [Asc SystemMessageManualPriority] .| C.mapM_ applyMessage
|
||||
where
|
||||
syncSystemMessageHidden :: UserId -> HandlerFor UniWorX ()
|
||||
syncSystemMessageHidden uid = runDB . withReaderT projectBackend $ do
|
||||
smSt <- lookupRegisteredCookiesJson id CookieSystemMessageState :: SqlPersistT (HandlerFor UniWorX) (MergeHashMap CryptoUUIDSystemMessage UserSystemMessageState)
|
||||
iforM_ smSt $ \cID UserSystemMessageState{..} -> do
|
||||
smId <- decrypt cID
|
||||
whenIsJust userSystemMessageHidden $ \systemMessageHiddenTime -> void $
|
||||
upsert SystemMessageHidden
|
||||
{ systemMessageHiddenMessage = smId
|
||||
, systemMessageHiddenUser = uid
|
||||
, systemMessageHiddenTime
|
||||
}
|
||||
[ SystemMessageHiddenTime =. systemMessageHiddenTime ]
|
||||
|
||||
when (maybe False (maybe (const True) (<=) userSystemMessageHidden) userSystemMessageUnhidden) $ do
|
||||
deleteBy $ UniqueSystemMessageHidden uid smId
|
||||
|
||||
modifyRegisteredCookieJson CookieSystemMessageState $ \(fold -> MergeHashMap hm)
|
||||
-> fmap MergeHashMap . assertM' (/= mempty) $
|
||||
HashMap.update (\smSt' -> assertM' (/= mempty) $ smSt' { userSystemMessageHidden = Nothing, userSystemMessageUnhidden = Nothing }) cID hm
|
||||
|
||||
applyMessage :: Entity SystemMessage -> ReaderT SqlReadBackend (HandlerFor UniWorX) ()
|
||||
applyMessage (Entity smId SystemMessage{..}) = maybeT_ $ do
|
||||
guard $ not systemMessageNewsOnly
|
||||
|
||||
cID <- encrypt smId
|
||||
void . assertM (== Authorized) . lift $ evalAccessDB (MessageR cID) False
|
||||
|
||||
now <- liftIO getCurrentTime
|
||||
guard $ NTop systemMessageFrom <= NTop (Just now)
|
||||
guard $ NTop (Just now) < NTop systemMessageTo
|
||||
|
||||
UserSystemMessageState{..} <- lift $ getSystemMessageState smId
|
||||
guard $ userSystemMessageShown <= Just systemMessageLastChanged
|
||||
guard $ userSystemMessageHidden <= Just systemMessageLastUnhide
|
||||
|
||||
(_, smTrans) <- MaybeT $ getSystemMessage appLanguages smId
|
||||
let
|
||||
(summary, content) = case smTrans of
|
||||
Nothing -> (systemMessageSummary, systemMessageContent)
|
||||
Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent)
|
||||
case summary of
|
||||
Just s ->
|
||||
addMessageWidget systemMessageSeverity $ msgModal (toWidget s) (Left . SomeRoute $ MessageR cID)
|
||||
Nothing -> addMessage systemMessageSeverity content
|
||||
|
||||
tellRegisteredCookieJson CookieSystemMessageState . MergeHashMap $
|
||||
HashMap.singleton cID mempty{ userSystemMessageShown = Just now }
|
||||
|
||||
|
||||
-- FIXME: Move headings into their respective handlers
|
||||
|
||||
-- | Method for specifying page heading for handlers that call defaultLayout
|
||||
--
|
||||
-- All handlers whose code is under our control should use
|
||||
-- `siteLayout` instead; `pageHeading` is only a fallback solution for
|
||||
-- e.g. subsites like `AuthR`
|
||||
pageHeading :: ( YesodPersist UniWorX
|
||||
, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
|
||||
) => Route UniWorX -> Maybe Widget
|
||||
pageHeading (AuthR _)
|
||||
= Just $ i18n MsgLoginHeading
|
||||
pageHeading NewsR
|
||||
= Just $ i18n MsgNewsHeading
|
||||
pageHeading UsersR
|
||||
= Just $ i18n MsgUsers
|
||||
pageHeading (AdminUserR _)
|
||||
= Just $ i18n MsgAdminUserHeading
|
||||
pageHeading AdminTestR
|
||||
= Just [whamlet|Internal Code Demonstration Page|]
|
||||
pageHeading AdminErrMsgR
|
||||
= Just $ i18n MsgErrMsgHeading
|
||||
|
||||
pageHeading InfoR
|
||||
= Just $ i18n MsgInfoHeading
|
||||
pageHeading LegalR
|
||||
= Just $ i18n MsgLegalHeading
|
||||
pageHeading VersionR
|
||||
= Just $ i18n MsgVersionHeading
|
||||
|
||||
pageHeading HelpR
|
||||
= Just $ i18n MsgHelpRequest
|
||||
|
||||
pageHeading ProfileR
|
||||
= Just $ i18n MsgProfileHeading
|
||||
pageHeading ProfileDataR
|
||||
= Just $ i18n MsgProfileDataHeading
|
||||
|
||||
pageHeading TermShowR
|
||||
= Just $ i18n MsgTermsHeading
|
||||
pageHeading TermCurrentR
|
||||
= Just $ i18n MsgTermCurrent
|
||||
pageHeading TermEditR
|
||||
= Just $ i18n MsgTermEditHeading
|
||||
pageHeading (TermEditExistR tid)
|
||||
= Just $ i18n $ MsgTermEditTid tid
|
||||
pageHeading (TermCourseListR tid)
|
||||
= Just . i18n . MsgTermCourseListHeading $ tid
|
||||
pageHeading (TermSchoolCourseListR tid ssh)
|
||||
= Just $ do
|
||||
School{schoolName=school} <- handlerToWidget . runDB . withReaderT (projectBackend @SqlBackend) $ get404 ssh
|
||||
i18n $ MsgTermSchoolCourseListHeading tid school
|
||||
|
||||
pageHeading CourseListR
|
||||
= Just $ i18n MsgCourseListTitle
|
||||
pageHeading CourseNewR
|
||||
= Just $ i18n MsgCourseNewHeading
|
||||
pageHeading (CourseR tid ssh csh CShowR)
|
||||
= Just $ do
|
||||
Entity _ Course{..} <- handlerToWidget . runDB . withReaderT (projectBackend @SqlBackend) . getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
toWidget courseName
|
||||
-- (CourseR tid csh CRegisterR) -- just for POST
|
||||
pageHeading (CourseR tid ssh csh CEditR)
|
||||
= Just $ i18n $ MsgCourseEditHeading tid ssh csh
|
||||
pageHeading (CourseR tid ssh csh CCorrectionsR)
|
||||
= Just $ i18n $ MsgSubmissionsCourse tid ssh csh
|
||||
pageHeading (CourseR tid ssh csh SheetListR)
|
||||
= Just $ i18n $ MsgSheetList tid ssh csh
|
||||
pageHeading (CourseR tid ssh csh SheetNewR)
|
||||
= Just $ i18n $ MsgSheetNewHeading tid ssh csh
|
||||
pageHeading (CSheetR tid ssh csh shn SShowR)
|
||||
= Just $ i18n $ MsgSheetTitle tid ssh csh shn
|
||||
-- = Just $ i18n $ prependCourseTitle tid ssh csh $ SomeMessage shn -- TODO: for consistency use prependCourseTitle throughout ERROR: circularity
|
||||
pageHeading (CSheetR tid ssh csh shn SEditR)
|
||||
= Just $ i18n $ MsgSheetEditHead tid ssh csh shn
|
||||
pageHeading (CSheetR tid ssh csh shn SDelR)
|
||||
= Just $ i18n $ MsgSheetDelHead tid ssh csh shn
|
||||
pageHeading (CSheetR _tid _ssh _csh shn SSubsR)
|
||||
= Just $ i18n $ MsgSubmissionsSheet shn
|
||||
pageHeading (CSheetR tid ssh csh shn SubmissionNewR)
|
||||
= Just $ i18n $ MsgSubmissionEditHead tid ssh csh shn
|
||||
pageHeading (CSheetR tid ssh csh shn SubmissionOwnR)
|
||||
= Just $ i18n $ MsgSubmissionEditHead tid ssh csh shn
|
||||
pageHeading (CSubmissionR tid ssh csh shn _ SubShowR) -- TODO: Rethink this one!
|
||||
= Just $ i18n $ MsgSubmissionEditHead tid ssh csh shn
|
||||
-- (CSubmissionR tid csh shn cid SubArchiveR) -- just a download
|
||||
pageHeading (CSubmissionR tid ssh csh shn cid CorrectionR)
|
||||
= Just $ i18n $ MsgCorrectionHead tid ssh csh shn cid
|
||||
-- (CSubmissionR tid csh shn cid SubDownloadR) -- just a download
|
||||
-- (CSheetR tid ssh csh shn SFileR) -- just for Downloads
|
||||
|
||||
pageHeading CorrectionsR
|
||||
= Just $ i18n MsgCorrectionsTitle
|
||||
pageHeading CorrectionsUploadR
|
||||
= Just $ i18n MsgCorrUpload
|
||||
pageHeading CorrectionsCreateR
|
||||
= Just $ i18n MsgCorrCreate
|
||||
pageHeading CorrectionsGradeR
|
||||
= Just $ i18n MsgCorrGrade
|
||||
pageHeading (MessageR _)
|
||||
= Just $ i18n MsgSystemMessageHeading
|
||||
pageHeading MessageListR
|
||||
= Just $ i18n MsgSystemMessageListHeading
|
||||
|
||||
-- TODO: add headings for more single course- and single term-pages
|
||||
pageHeading _
|
||||
= Nothing
|
||||
@ -7,6 +7,7 @@ module Foundation.Type
|
||||
, _SessionStorageMemcachedSql, _SessionStorageAcid
|
||||
, SMTPPool
|
||||
, _appSettings', _appStatic, _appConnPool, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionStore, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport
|
||||
, DB, Form, MsgRenderer, MailM
|
||||
) where
|
||||
|
||||
import Import.NoFoundation
|
||||
@ -74,3 +75,9 @@ instance HasCookieSettings RegisteredCookie UniWorX where
|
||||
|
||||
instance (MonadHandler m, HandlerSite m ~ UniWorX) => ReadLogSettings m where
|
||||
readLogSettings = liftIO . readTVarIO =<< getsYesod (view _appLogSettings)
|
||||
|
||||
|
||||
type DB = YesodDB UniWorX
|
||||
type Form x = Html -> MForm (HandlerFor UniWorX) (FormResult x, WidgetFor UniWorX ())
|
||||
type MsgRenderer = MsgRendererS UniWorX -- see Utils
|
||||
type MailM a = MailT (HandlerFor UniWorX) a
|
||||
|
||||
498
src/Foundation/Yesod/Auth.hs
Normal file
498
src/Foundation/Yesod/Auth.hs
Normal file
@ -0,0 +1,498 @@
|
||||
module Foundation.Yesod.Auth
|
||||
( authenticate
|
||||
, upsertCampusUser
|
||||
, CampusUserConversionException(..)
|
||||
, campusUserFailoverMode, updateUserLanguage
|
||||
) where
|
||||
|
||||
import Import.NoFoundation hiding (authenticate)
|
||||
|
||||
import Foundation.Type
|
||||
import Foundation.Types
|
||||
import Foundation.I18n
|
||||
|
||||
import Handler.Utils.Profile
|
||||
import Handler.Utils.StudyFeatures
|
||||
import Handler.Utils.SchoolLdap
|
||||
|
||||
import Yesod.Auth.Message
|
||||
import Auth.LDAP
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Control.Monad.Catch as C (Handler(..))
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import qualified Ldap.Client as Ldap
|
||||
import qualified Data.Text.Encoding as Text
|
||||
import qualified Data.ByteString as ByteString
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Conduit.Combinators as C
|
||||
|
||||
import qualified Data.List as List ((\\))
|
||||
|
||||
import qualified Data.UUID as UUID
|
||||
import Data.ByteArray (convert)
|
||||
import Crypto.Hash (SHAKE128)
|
||||
import qualified Data.Binary as Binary
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import Control.Monad.Writer.Class (MonadWriter(..))
|
||||
import Crypto.Hash.Conduit (sinkHash)
|
||||
|
||||
|
||||
authenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, YesodPersist UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
|
||||
, YesodAuth UniWorX, UserId ~ AuthId UniWorX
|
||||
)
|
||||
=> Creds UniWorX -> m (AuthenticationResult UniWorX)
|
||||
authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $ do
|
||||
now <- liftIO getCurrentTime
|
||||
|
||||
let
|
||||
uAuth = UniqueAuthentication $ CI.mk credsIdent
|
||||
upsertMode = creds ^? _upsertCampusUserMode
|
||||
|
||||
isDummy = is (_Just . _UpsertCampusUserDummy) upsertMode
|
||||
isOther = is (_Just . _UpsertCampusUserOther) upsertMode
|
||||
|
||||
excRecovery res
|
||||
| isDummy || isOther
|
||||
= do
|
||||
case res of
|
||||
UserError err -> addMessageI Error err
|
||||
ServerError err -> addMessage Error $ toHtml err
|
||||
_other -> return ()
|
||||
acceptExisting
|
||||
| otherwise
|
||||
= return res
|
||||
|
||||
excHandlers =
|
||||
[ C.Handler $ \case
|
||||
CampusUserNoResult -> do
|
||||
$logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent
|
||||
excRecovery . UserError $ IdentifierNotFound credsIdent
|
||||
CampusUserAmbiguous -> do
|
||||
$logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent
|
||||
excRecovery . UserError $ IdentifierNotFound credsIdent
|
||||
err -> do
|
||||
$logErrorS "LDAP" $ tshow err
|
||||
mr <- getMessageRender
|
||||
excRecovery . ServerError $ mr MsgInternalLdapError
|
||||
, C.Handler $ \(cExc :: CampusUserConversionException) -> do
|
||||
$logErrorS "LDAP" $ tshow cExc
|
||||
mr <- getMessageRender
|
||||
excRecovery . ServerError $ mr cExc
|
||||
]
|
||||
|
||||
acceptExisting :: SqlPersistT (HandlerFor UniWorX) (AuthenticationResult UniWorX)
|
||||
acceptExisting = do
|
||||
res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
|
||||
case res of
|
||||
Authenticated uid
|
||||
-> associateUserSchoolsByTerms uid
|
||||
_other
|
||||
-> return ()
|
||||
case res of
|
||||
Authenticated uid
|
||||
| not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ]
|
||||
_other -> return res
|
||||
|
||||
$logDebugS "auth" $ tshow Creds{..}
|
||||
UniWorX{..} <- getYesod
|
||||
|
||||
flip catches excHandlers $ case appLdapPool of
|
||||
Just ldapPool
|
||||
| Just upsertMode' <- upsertMode -> do
|
||||
ldapData <- campusUser ldapPool campusUserFailoverMode Creds{..}
|
||||
$logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData
|
||||
Authenticated . entityKey <$> upsertCampusUser upsertMode' ldapData
|
||||
_other
|
||||
-> acceptExisting
|
||||
|
||||
|
||||
data CampusUserConversionException
|
||||
= CampusUserInvalidIdent
|
||||
| CampusUserInvalidEmail
|
||||
| CampusUserInvalidDisplayName
|
||||
| CampusUserInvalidGivenName
|
||||
| CampusUserInvalidSurname
|
||||
| CampusUserInvalidTitle
|
||||
| CampusUserInvalidMatriculation
|
||||
| CampusUserInvalidSex
|
||||
| CampusUserInvalidFeaturesOfStudy Text
|
||||
| CampusUserInvalidAssociatedSchools Text
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriving anyclass (Exception)
|
||||
|
||||
_upsertCampusUserMode :: Traversal' (Creds UniWorX) UpsertCampusUserMode
|
||||
_upsertCampusUserMode mMode cs@Creds{..}
|
||||
| credsPlugin == "dummy" = setMode <$> mMode (UpsertCampusUserDummy $ CI.mk credsIdent)
|
||||
| credsPlugin `elem` others = setMode <$> mMode (UpsertCampusUserOther $ CI.mk credsIdent)
|
||||
| otherwise = setMode <$> mMode UpsertCampusUser
|
||||
where
|
||||
setMode UpsertCampusUser
|
||||
= cs{ credsPlugin = "LDAP" }
|
||||
setMode (UpsertCampusUserDummy ident)
|
||||
= cs{ credsPlugin = "dummy", credsIdent = CI.original ident }
|
||||
setMode (UpsertCampusUserOther ident)
|
||||
= cs{ credsPlugin = bool (NonEmpty.head others) credsPlugin (credsPlugin `elem` others), credsIdent = CI.original ident }
|
||||
|
||||
others = "PWHash" :| []
|
||||
|
||||
upsertCampusUser :: forall m.
|
||||
( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, MonadThrow m
|
||||
)
|
||||
=> UpsertCampusUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User)
|
||||
upsertCampusUser plugin ldapData = do
|
||||
now <- liftIO getCurrentTime
|
||||
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
|
||||
|
||||
let
|
||||
userIdent'' = fold [ v | (k, v) <- ldapData, k == ldapUserPrincipalName ]
|
||||
userMatrikelnummer' = fold [ v | (k, v) <- ldapData, k == ldapUserMatriculation ]
|
||||
userEmail' = fold $ do
|
||||
k' <- toList ldapUserEmail
|
||||
(k, v) <- ldapData
|
||||
guard $ k' == k
|
||||
return v
|
||||
userDisplayName'' = fold [ v | (k, v) <- ldapData, k == ldapUserDisplayName ]
|
||||
userFirstName' = fold [ v | (k, v) <- ldapData, k == ldapUserFirstName ]
|
||||
userSurname' = fold [ v | (k, v) <- ldapData, k == ldapUserSurname ]
|
||||
userTitle' = fold [ v | (k, v) <- ldapData, k == ldapUserTitle ]
|
||||
userSex' = fold [ v | (k, v) <- ldapData, k == ldapSex ]
|
||||
|
||||
userAuthentication
|
||||
| is _UpsertCampusUserOther plugin
|
||||
= error "PWHash should only work for users that are already known"
|
||||
| otherwise = AuthLDAP
|
||||
userLastAuthentication = now <$ guard (isn't _UpsertCampusUserDummy plugin)
|
||||
|
||||
userIdent <- if
|
||||
| [bs] <- userIdent''
|
||||
, Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs
|
||||
, hasn't _upsertCampusUserIdent plugin || has (_upsertCampusUserIdent . only userIdent') plugin
|
||||
-> return userIdent'
|
||||
| Just userIdent' <- plugin ^? _upsertCampusUserIdent
|
||||
-> return userIdent'
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidIdent
|
||||
userEmail <- if
|
||||
| userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') userEmail'
|
||||
-> return $ CI.mk userEmail
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidEmail
|
||||
userDisplayName' <- if
|
||||
| [bs] <- userDisplayName''
|
||||
, Right userDisplayName' <- Text.decodeUtf8' bs
|
||||
-> return userDisplayName'
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidDisplayName
|
||||
userFirstName <- if
|
||||
| [bs] <- userFirstName'
|
||||
, Right userFirstName <- Text.decodeUtf8' bs
|
||||
-> return userFirstName
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidGivenName
|
||||
userSurname <- if
|
||||
| [bs] <- userSurname'
|
||||
, Right userSurname <- Text.decodeUtf8' bs
|
||||
-> return userSurname
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidSurname
|
||||
userTitle <- if
|
||||
| all ByteString.null userTitle'
|
||||
-> return Nothing
|
||||
| [bs] <- userTitle'
|
||||
, Right userTitle <- Text.decodeUtf8' bs
|
||||
-> return $ Just userTitle
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidTitle
|
||||
userMatrikelnummer <- if
|
||||
| [bs] <- userMatrikelnummer'
|
||||
, Right userMatrikelnummer <- Text.decodeUtf8' bs
|
||||
-> return $ Just userMatrikelnummer
|
||||
| [] <- userMatrikelnummer'
|
||||
-> return Nothing
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidMatriculation
|
||||
userSex <- if
|
||||
| [bs] <- userSex'
|
||||
, Right userSex'' <- Text.decodeUtf8' bs
|
||||
, Just userSex''' <- readMay userSex''
|
||||
, Just userSex <- userSex''' ^? iso5218
|
||||
-> return $ Just userSex
|
||||
| [] <- userSex'
|
||||
-> return Nothing
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidSex
|
||||
|
||||
let
|
||||
newUser = User
|
||||
{ userMaxFavourites = userDefaultMaxFavourites
|
||||
, userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
|
||||
, userTheme = userDefaultTheme
|
||||
, userDateTimeFormat = userDefaultDateTimeFormat
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
, userTimeFormat = userDefaultTimeFormat
|
||||
, userDownloadFiles = userDefaultDownloadFiles
|
||||
, userWarningDays = userDefaultWarningDays
|
||||
, userShowSex = userDefaultShowSex
|
||||
, userNotificationSettings = def
|
||||
, userLanguages = Nothing
|
||||
, userCsvOptions = def
|
||||
, userTokensIssuedAfter = Nothing
|
||||
, userCreated = now
|
||||
, userLastLdapSynchronisation = Just now
|
||||
, userDisplayName = userDisplayName'
|
||||
, userDisplayEmail = userEmail
|
||||
, ..
|
||||
}
|
||||
userUpdate = [ UserMatrikelnummer =. userMatrikelnummer
|
||||
-- , UserDisplayName =. userDisplayName
|
||||
, UserFirstName =. userFirstName
|
||||
, UserSurname =. userSurname
|
||||
, UserTitle =. userTitle
|
||||
, UserEmail =. userEmail
|
||||
, UserSex =. userSex
|
||||
, UserLastLdapSynchronisation =. Just now
|
||||
] ++
|
||||
[ UserLastAuthentication =. Just now | isn't _UpsertCampusUserDummy plugin ]
|
||||
|
||||
user@(Entity userId userRec) <- upsertBy (UniqueAuthentication userIdent) newUser userUpdate
|
||||
unless (validDisplayName userTitle userFirstName userSurname $ userDisplayName userRec) $
|
||||
update userId [ UserDisplayName =. userDisplayName' ]
|
||||
|
||||
let
|
||||
userStudyFeatures = fmap concat . forM userStudyFeatures' $ parseStudyFeatures userId now
|
||||
userStudyFeatures' = do
|
||||
(k, v) <- ldapData
|
||||
guard $ k == ldapUserStudyFeatures
|
||||
v' <- v
|
||||
Right str <- return $ Text.decodeUtf8' v'
|
||||
return str
|
||||
|
||||
termNames = nubBy ((==) `on` CI.mk) $ do
|
||||
(k, v) <- ldapData
|
||||
guard $ k == ldapUserFieldName
|
||||
v' <- v
|
||||
Right str <- return $ Text.decodeUtf8' v'
|
||||
return str
|
||||
|
||||
userSubTermsSemesters = forM userSubTermsSemesters' parseSubTermsSemester
|
||||
userSubTermsSemesters' = do
|
||||
(k, v) <- ldapData
|
||||
guard $ k == ldapUserSubTermsSemester
|
||||
v' <- v
|
||||
Right str <- return $ Text.decodeUtf8' v'
|
||||
return str
|
||||
|
||||
fs' <- either (throwM . CampusUserInvalidFeaturesOfStudy . tshow) return userStudyFeatures
|
||||
sts <- either (throwM . CampusUserInvalidFeaturesOfStudy . tshow) return userSubTermsSemesters
|
||||
|
||||
let
|
||||
studyTermCandidates = Set.fromList $ do
|
||||
let sfKeys = unStudyTermsKey . studyFeaturesField <$> fs'
|
||||
subTermsKeys = unStudyTermsKey . fst <$> sts
|
||||
|
||||
(,) <$> sfKeys ++ subTermsKeys <*> termNames
|
||||
|
||||
let
|
||||
assimilateSubTerms :: [(StudyTermsId, Int)] -> [StudyFeatures] -> WriterT (Set (StudyTermsId, Maybe StudyTermsId)) (SqlPersistT m) [StudyFeatures]
|
||||
assimilateSubTerms [] xs = return xs
|
||||
assimilateSubTerms ((subterm, subSemester) : subterms) unusedFeats = do
|
||||
standalone <- lift $ get subterm
|
||||
case standalone of
|
||||
_other
|
||||
| (match : matches, unusedFeats') <- partition
|
||||
(\StudyFeatures{..} -> subterm == studyFeaturesField
|
||||
&& subSemester == studyFeaturesSemester
|
||||
) unusedFeats
|
||||
-> do
|
||||
$logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}” and matching feature “#{tshow match}”|]
|
||||
(:) match <$> assimilateSubTerms subterms (matches ++ unusedFeats')
|
||||
| any ((== subterm) . studyFeaturesField) unusedFeats
|
||||
-> do
|
||||
$logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}” due to feature of matching field|]
|
||||
assimilateSubTerms subterms unusedFeats
|
||||
Just StudyTerms{..}
|
||||
| Just defDegree <- studyTermsDefaultDegree
|
||||
, Just defType <- studyTermsDefaultType
|
||||
-> do
|
||||
$logDebugS "Campus" [st|Applying default for standalone study term “#{tshow subterm}”|]
|
||||
(:) (StudyFeatures userId defDegree subterm Nothing defType subSemester now True) <$> assimilateSubTerms subterms unusedFeats
|
||||
Nothing
|
||||
| [] <- unusedFeats -> do
|
||||
$logDebugS "Campus" [st|Saw subterm “#{tshow subterm}” when no fos-terms remain|]
|
||||
tell $ Set.singleton (subterm, Nothing)
|
||||
assimilateSubTerms subterms []
|
||||
_other -> do
|
||||
knownParents <- lift $ map (studySubTermsParent . entityVal) <$> selectList [ StudySubTermsChild ==. subterm ] []
|
||||
let matchingFeatures = case knownParents of
|
||||
[] -> filter ((== subSemester) . studyFeaturesSemester) unusedFeats
|
||||
ps -> filter (\StudyFeatures{studyFeaturesField, studyFeaturesSemester} -> elem studyFeaturesField ps && studyFeaturesSemester == subSemester) unusedFeats
|
||||
when (null knownParents) . forM_ matchingFeatures $ \StudyFeatures{..} ->
|
||||
tell $ Set.singleton (subterm, Just studyFeaturesField)
|
||||
if
|
||||
| not $ null knownParents -> do
|
||||
$logDebugS "Campus" [st|Applying subterm “#{tshow subterm}” to #{tshow matchingFeatures}|]
|
||||
let setSuperField sf = sf
|
||||
& _studyFeaturesSuperField %~ (<|> Just (sf ^. _studyFeaturesField))
|
||||
& _studyFeaturesField .~ subterm
|
||||
(++) (map setSuperField matchingFeatures) <$> assimilateSubTerms subterms (unusedFeats List.\\ matchingFeatures)
|
||||
| otherwise -> do
|
||||
$logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}”|]
|
||||
assimilateSubTerms subterms unusedFeats
|
||||
$logDebugS "Campus" [st|Terms for “#{userIdent}”: #{tshow (sts, fs')}|]
|
||||
(fs, studyFieldParentCandidates) <- runWriterT $ assimilateSubTerms sts fs'
|
||||
|
||||
let
|
||||
studyTermCandidateIncidence
|
||||
= fromMaybe (error "Could not convert studyTermCandidateIncidence-Hash to UUID") -- Should never happen
|
||||
. UUID.fromByteString
|
||||
. fromStrict
|
||||
. (convert :: Digest (SHAKE128 128) -> ByteString)
|
||||
. runConduitPure
|
||||
$ C.yieldMany ((toStrict . Binary.encode <$> Set.toList studyTermCandidates) ++ (toStrict . Binary.encode <$> Set.toList studyFieldParentCandidates)) .| sinkHash
|
||||
|
||||
candidatesRecorded <- E.selectExists . E.from $ \(candidate `E.FullOuterJoin` parentCandidate `E.FullOuterJoin` standaloneCandidate) -> do
|
||||
E.on $ candidate E.?. StudyTermNameCandidateIncidence E.==. standaloneCandidate E.?. StudyTermStandaloneCandidateIncidence
|
||||
E.on $ candidate E.?. StudyTermNameCandidateIncidence E.==. parentCandidate E.?. StudySubTermParentCandidateIncidence
|
||||
E.where_ $ candidate E.?. StudyTermNameCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence)
|
||||
E.||. parentCandidate E.?. StudySubTermParentCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence)
|
||||
E.||. standaloneCandidate E.?. StudyTermStandaloneCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence)
|
||||
|
||||
unless candidatesRecorded $ do
|
||||
let
|
||||
studyTermCandidates' = do
|
||||
(studyTermNameCandidateKey, studyTermNameCandidateName) <- Set.toList studyTermCandidates
|
||||
let studyTermNameCandidateIncidence = studyTermCandidateIncidence
|
||||
return StudyTermNameCandidate{..}
|
||||
insertMany_ studyTermCandidates'
|
||||
|
||||
let
|
||||
studySubTermParentCandidates' = do
|
||||
(StudyTermsKey' studySubTermParentCandidateKey, Just (StudyTermsKey' studySubTermParentCandidateParent)) <- Set.toList studyFieldParentCandidates
|
||||
let studySubTermParentCandidateIncidence = studyTermCandidateIncidence
|
||||
return StudySubTermParentCandidate{..}
|
||||
insertMany_ studySubTermParentCandidates'
|
||||
|
||||
let
|
||||
studyTermStandaloneCandidates' = do
|
||||
(StudyTermsKey' studyTermStandaloneCandidateKey, Nothing) <- Set.toList studyFieldParentCandidates
|
||||
let studyTermStandaloneCandidateIncidence = studyTermCandidateIncidence
|
||||
return StudyTermStandaloneCandidate{..}
|
||||
insertMany_ studyTermStandaloneCandidates'
|
||||
|
||||
E.updateWhere [StudyFeaturesUser ==. userId] [StudyFeaturesValid =. False]
|
||||
forM_ fs $ \f@StudyFeatures{..} -> do
|
||||
insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
|
||||
insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing Nothing Nothing
|
||||
oldFs <- selectKeysList
|
||||
[ StudyFeaturesUser ==. studyFeaturesUser
|
||||
, StudyFeaturesDegree ==. studyFeaturesDegree
|
||||
, StudyFeaturesField ==. studyFeaturesField
|
||||
, StudyFeaturesType ==. studyFeaturesType
|
||||
, StudyFeaturesSemester ==. studyFeaturesSemester
|
||||
]
|
||||
[]
|
||||
case oldFs of
|
||||
[oldF] -> update oldF
|
||||
[ StudyFeaturesUpdated =. now
|
||||
, StudyFeaturesValid =. True
|
||||
, StudyFeaturesField =. studyFeaturesField
|
||||
, StudyFeaturesSuperField =. studyFeaturesSuperField
|
||||
]
|
||||
_other -> void $ upsert f
|
||||
[ StudyFeaturesUpdated =. now
|
||||
, StudyFeaturesValid =. True
|
||||
, StudyFeaturesSuperField =. studyFeaturesSuperField
|
||||
]
|
||||
associateUserSchoolsByTerms userId
|
||||
|
||||
let
|
||||
userAssociatedSchools = concat <$> forM userAssociatedSchools' parseLdapSchools
|
||||
userAssociatedSchools' = do
|
||||
(k, v) <- ldapData
|
||||
guard $ k == ldapUserSchoolAssociation
|
||||
v' <- v
|
||||
Right str <- return $ Text.decodeUtf8' v'
|
||||
return str
|
||||
|
||||
ss <- either (throwM . CampusUserInvalidAssociatedSchools . tshow) return userAssociatedSchools
|
||||
|
||||
forM_ ss $ \frag -> void . runMaybeT $ do
|
||||
let
|
||||
exactMatch = MaybeT . getBy $ UniqueOrgUnit frag
|
||||
infixMatch = (hoistMaybe . preview _head) <=< (lift . E.select . E.from) $ \schoolLdap -> do
|
||||
E.where_ $ E.val frag `E.isInfixOf` schoolLdap E.^. SchoolLdapOrgUnit
|
||||
E.&&. E.not_ (E.isNothing $ schoolLdap E.^. SchoolLdapSchool)
|
||||
return schoolLdap
|
||||
Entity _ SchoolLdap{..} <- exactMatch <|> infixMatch
|
||||
ssh <- hoistMaybe schoolLdapSchool
|
||||
|
||||
lift . void $ insertUnique UserSchool
|
||||
{ userSchoolUser = userId
|
||||
, userSchoolSchool = ssh
|
||||
, userSchoolIsOptOut = False
|
||||
}
|
||||
|
||||
forM_ ss $ void . insertUnique . SchoolLdap Nothing
|
||||
|
||||
return user
|
||||
where
|
||||
insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())
|
||||
|
||||
associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m ()
|
||||
associateUserSchoolsByTerms uid = do
|
||||
sfs <- selectList [StudyFeaturesUser ==. uid] []
|
||||
|
||||
forM_ sfs $ \(Entity _ StudyFeatures{..}) -> do
|
||||
schoolTerms <- selectList [SchoolTermsTerms ==. studyFeaturesField] []
|
||||
forM_ schoolTerms $ \(Entity _ SchoolTerms{..}) ->
|
||||
void $ insertUnique UserSchool
|
||||
{ userSchoolUser = uid
|
||||
, userSchoolSchool = schoolTermsSchool
|
||||
, userSchoolIsOptOut = False
|
||||
}
|
||||
|
||||
updateUserLanguage :: ( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, YesodAuth UniWorX
|
||||
, UserId ~ AuthId UniWorX
|
||||
)
|
||||
=> Maybe Lang -> SqlPersistT m (Maybe Lang)
|
||||
updateUserLanguage (Just lang) = do
|
||||
unless (lang `elem` appLanguages) $
|
||||
invalidArgs ["Unsupported language"]
|
||||
|
||||
muid <- maybeAuthId
|
||||
for_ muid $ \uid -> do
|
||||
langs <- languages
|
||||
update uid [ UserLanguages =. Just (Languages $ lang : nub (filter ((&&) <$> (`elem` appLanguages) <*> (/= lang)) langs)) ]
|
||||
setRegisteredCookie CookieLang lang
|
||||
return $ Just lang
|
||||
updateUserLanguage Nothing = runMaybeT $ do
|
||||
uid <- MaybeT maybeAuthId
|
||||
User{..} <- MaybeT $ get uid
|
||||
setLangs <- toList . selectLanguages appLanguages <$> languages
|
||||
highPrioSetLangs <- toList . selectLanguages appLanguages <$> highPrioRequestedLangs
|
||||
let userLanguages' = toList . selectLanguages appLanguages <$> userLanguages ^? _Just . _Wrapped
|
||||
lang <- case (userLanguages', setLangs, highPrioSetLangs) of
|
||||
(_, _, hpl : _)
|
||||
-> lift $ hpl <$ update uid [ UserLanguages =. Just (Languages highPrioSetLangs) ]
|
||||
(Just (l : _), _, _)
|
||||
-> return l
|
||||
(Nothing, l : _, _)
|
||||
-> lift $ l <$ update uid [ UserLanguages =. Just (Languages setLangs) ]
|
||||
(Just [], l : _, _)
|
||||
-> return l
|
||||
(_, [], _)
|
||||
-> mzero
|
||||
setRegisteredCookie CookieLang lang
|
||||
return lang
|
||||
|
||||
campusUserFailoverMode :: FailoverMode
|
||||
campusUserFailoverMode = FailoverUnlimited
|
||||
|
||||
embedRenderMessage ''UniWorX ''CampusUserConversionException id
|
||||
90
src/Foundation/Yesod/ErrorHandler.hs
Normal file
90
src/Foundation/Yesod/ErrorHandler.hs
Normal file
@ -0,0 +1,90 @@
|
||||
module Foundation.Yesod.ErrorHandler
|
||||
( errorHandler
|
||||
) where
|
||||
|
||||
import Import.NoFoundation hiding (errorHandler)
|
||||
|
||||
import Utils.Form
|
||||
|
||||
import Foundation.Type
|
||||
import Foundation.I18n
|
||||
import Foundation.Authorization
|
||||
import Foundation.SiteLayout
|
||||
import Foundation.Routes
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.Text as Text
|
||||
|
||||
|
||||
errorHandler :: ( MonadSecretBox (HandlerFor UniWorX)
|
||||
, MonadSecretBox (WidgetFor UniWorX)
|
||||
, BearerAuthSite UniWorX
|
||||
, Button UniWorX ButtonSubmit
|
||||
, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
|
||||
)
|
||||
=> ErrorResponse -> HandlerFor UniWorX TypedContent
|
||||
errorHandler err = do
|
||||
shouldEncrypt <- do
|
||||
canDecrypt <- (== Authorized) <$> evalAccess AdminErrMsgR True
|
||||
shouldEncrypt <- getsYesod $ view _appEncryptErrors
|
||||
return $ shouldEncrypt && not canDecrypt
|
||||
|
||||
sessErr <- bool return (_InternalError $ encodedSecretBox SecretBoxShort) shouldEncrypt err
|
||||
setSessionJson SessionError sessErr
|
||||
|
||||
selectRep $ do
|
||||
provideRep $ do
|
||||
mr <- getMessageRender
|
||||
let
|
||||
encrypted :: ToJSON a => a -> WidgetFor UniWorX () -> WidgetFor UniWorX ()
|
||||
encrypted plaintextJson plaintext = do
|
||||
if
|
||||
| shouldEncrypt -> do
|
||||
ciphertext <- encodedSecretBox SecretBoxPretty plaintextJson
|
||||
|
||||
[whamlet|
|
||||
<p>_{MsgErrorResponseEncrypted}
|
||||
<pre .errMsg>
|
||||
#{ciphertext}
|
||||
|]
|
||||
| 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)}|]
|
||||
siteLayout (toWgt . mr $ ErrorResponseTitle err) $ do
|
||||
toWidget
|
||||
[cassius|
|
||||
.errMsg
|
||||
white-space: pre-wrap
|
||||
font-family: monospace
|
||||
|]
|
||||
errPage
|
||||
provideRep . fmap PrettyValue $ case err of
|
||||
PermissionDenied err' -> return $ object [ "message" JSON..= err' ]
|
||||
InternalError err'
|
||||
| shouldEncrypt -> do
|
||||
ciphertext <- encodedSecretBox SecretBoxShort err'
|
||||
return $ object [ "message" JSON..= ciphertext
|
||||
, "encrypted" JSON..= True
|
||||
]
|
||||
| otherwise -> return $ object [ "message" JSON..= err' ]
|
||||
InvalidArgs errs -> return $ object [ "messages" JSON..= errs ]
|
||||
_other -> return $ object []
|
||||
provideRep $ case err of
|
||||
PermissionDenied err' -> return err'
|
||||
InternalError err'
|
||||
| shouldEncrypt -> do
|
||||
addHeader "Encrypted-Error-Message" "True"
|
||||
encodedSecretBox SecretBoxPretty err'
|
||||
| otherwise -> return err'
|
||||
InvalidArgs errs -> return . Text.unlines . map (Text.replace "\n" "\n\t") $ errs
|
||||
_other -> return Text.empty
|
||||
251
src/Foundation/Yesod/Middleware.hs
Normal file
251
src/Foundation/Yesod/Middleware.hs
Normal file
@ -0,0 +1,251 @@
|
||||
module Foundation.Yesod.Middleware
|
||||
( yesodMiddleware
|
||||
, updateFavourites
|
||||
) where
|
||||
|
||||
import Import.NoFoundation hiding (yesodMiddleware)
|
||||
|
||||
import Foundation.Type
|
||||
import Foundation.Routes
|
||||
import Foundation.I18n
|
||||
import Foundation.Authorization
|
||||
|
||||
import Utils.Metrics
|
||||
|
||||
import qualified Network.Wai as W
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Control.Monad.Reader.Class (MonadReader(..))
|
||||
import Control.Monad.Writer.Class (MonadWriter(..))
|
||||
|
||||
import Yesod.Core.Types (GHState(..), HandlerData(..), RunHandlerEnv(rheSite, rheChild))
|
||||
|
||||
|
||||
yesodMiddleware :: ( BearerAuthSite UniWorX
|
||||
, BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX)
|
||||
, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
|
||||
)
|
||||
=> HandlerFor UniWorX res -> HandlerFor UniWorX res
|
||||
yesodMiddleware = storeBearerMiddleware . csrfMiddleware . dryRunMiddleware . observeYesodCacheSizeMiddleware . languagesMiddleware appLanguages . headerMessagesMiddleware . defaultYesodMiddleware . normalizeRouteMiddleware . updateFavouritesMiddleware
|
||||
where
|
||||
dryRunMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
|
||||
dryRunMiddleware handler = do
|
||||
dryRun <- isDryRun
|
||||
if | dryRun -> do
|
||||
hData <- ask
|
||||
prevState <- readIORef (handlerState hData)
|
||||
let
|
||||
restoreSession =
|
||||
modifyIORef (handlerState hData) $
|
||||
\hst -> hst { ghsSession = ghsSession prevState
|
||||
, ghsCache = ghsCache prevState
|
||||
, ghsCacheBy = ghsCacheBy prevState
|
||||
}
|
||||
site' = (rheSite $ handlerEnv hData) { appMemcached = Nothing }
|
||||
handler' = local (\hd -> hd { handlerEnv = (handlerEnv hd) { rheSite = site', rheChild = site' } }) handler
|
||||
|
||||
addCustomHeader HeaderDryRun $ toPathPiece True
|
||||
|
||||
handler' `finally` restoreSession
|
||||
| otherwise -> handler
|
||||
updateFavouritesMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
|
||||
updateFavouritesMiddleware handler = (*> handler) . runMaybeT $ do
|
||||
route <- MaybeT getCurrentRoute
|
||||
case route of -- update Course Favourites here
|
||||
CourseR tid ssh csh _ -> do
|
||||
void . lift . runDB . runMaybeT $ do
|
||||
guardM . lift $ (== Authorized) <$> evalAccessDB (CourseR tid ssh csh CShowR) False
|
||||
lift . updateFavourites $ Just (tid, ssh, csh)
|
||||
_other -> return ()
|
||||
normalizeRouteMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
|
||||
normalizeRouteMiddleware handler = (*> handler) . runMaybeT $ do
|
||||
route <- MaybeT getCurrentRoute
|
||||
(route', getAny -> changed) <- lift . runDB . runWriterT $ foldM (&) route routeNormalizers
|
||||
when changed $ do
|
||||
$logDebugS "normalizeRouteMiddleware" [st|Redirecting to #{tshow route'}|]
|
||||
redirectWith movedPermanently301 route'
|
||||
headerMessagesMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
|
||||
headerMessagesMiddleware handler = (handler `finally`) . runMaybeT $ do
|
||||
isModal <- hasCustomHeader HeaderIsModal
|
||||
dbTableShortcircuit <- hasCustomHeader HeaderDBTableShortcircuit
|
||||
massInputShortcircuit <- hasCustomHeader HeaderMassInputShortcircuit
|
||||
$logDebugS "headerMessagesMiddleware" $ tshow (isModal, dbTableShortcircuit, massInputShortcircuit)
|
||||
guard $ or
|
||||
[ isModal
|
||||
, dbTableShortcircuit
|
||||
, massInputShortcircuit
|
||||
]
|
||||
|
||||
lift . bracketOnError getMessages (mapM_ addMessage') $
|
||||
addCustomHeader HeaderAlerts . decodeUtf8 . urlEncode True . toStrict . JSON.encode
|
||||
observeYesodCacheSizeMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
|
||||
observeYesodCacheSizeMiddleware handler = handler `finally` observeYesodCacheSize
|
||||
csrfMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
|
||||
csrfMiddleware handler = do
|
||||
hasBearer <- is _Just <$> lookupBearerAuth
|
||||
|
||||
if | hasBearer -> local (\HandlerData{..} -> HandlerData{ handlerRequest = handlerRequest { reqToken = Nothing }, .. }) handler
|
||||
| otherwise -> csrfSetCookieMiddleware' . defaultCsrfCheckMiddleware $ handler
|
||||
where
|
||||
csrfSetCookieMiddleware' handler' = do
|
||||
mcsrf <- reqToken <$> getRequest
|
||||
whenIsJust mcsrf $ setRegisteredCookie CookieXSRFToken
|
||||
handler'
|
||||
storeBearerMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
|
||||
storeBearerMiddleware handler = do
|
||||
askBearer >>= \case
|
||||
Just (Jwt bs) -> setSessionBS (toPathPiece SessionBearer) bs
|
||||
Nothing -> return ()
|
||||
|
||||
handler
|
||||
|
||||
updateFavourites :: forall m backend.
|
||||
( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, BackendCompatible SqlBackend backend
|
||||
, YesodAuth UniWorX
|
||||
, UserId ~ AuthId UniWorX
|
||||
)
|
||||
=> Maybe (TermId, SchoolId, CourseShorthand) -- ^ Insert course into favourites, as appropriate
|
||||
-> ReaderT backend m ()
|
||||
updateFavourites cData = void . withReaderT projectBackend . runMaybeT $ do
|
||||
$logDebugS "updateFavourites" "Updating favourites"
|
||||
|
||||
now <- liftIO getCurrentTime
|
||||
uid <- MaybeT $ liftHandler maybeAuthId
|
||||
mcid <- (for cData $ \(tid, ssh, csh) -> MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh) :: MaybeT (SqlPersistT m) (Maybe CourseId)
|
||||
User{userMaxFavourites} <- MaybeT $ get uid
|
||||
|
||||
-- update Favourites
|
||||
for_ mcid $ \cid ->
|
||||
void . lift $ upsertBy
|
||||
(UniqueCourseFavourite uid cid)
|
||||
(CourseFavourite uid cid FavouriteVisited now)
|
||||
[CourseFavouriteLastVisit =. now]
|
||||
-- prune Favourites to user-defined size
|
||||
oldFavs <- lift $ selectList [CourseFavouriteUser ==. uid] []
|
||||
let deleteFavs = oldFavs
|
||||
& sortOn ((courseFavouriteReason &&& Down . courseFavouriteLastVisit) . entityVal)
|
||||
& drop userMaxFavourites
|
||||
& filter ((<= FavouriteVisited) . courseFavouriteReason . entityVal)
|
||||
& map entityKey
|
||||
unless (null deleteFavs) $
|
||||
lift $ deleteWhere [CourseFavouriteId <-. deleteFavs]
|
||||
|
||||
|
||||
routeNormalizers :: forall m backend.
|
||||
( BackendCompatible SqlReadBackend backend
|
||||
, MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, BearerAuthSite UniWorX
|
||||
) => [Route UniWorX -> WriterT Any (ReaderT backend m) (Route UniWorX)]
|
||||
routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) .)
|
||||
[ normalizeRender
|
||||
, ncSchool
|
||||
, ncAllocation
|
||||
, ncCourse
|
||||
, ncSheet
|
||||
, ncMaterial
|
||||
, ncTutorial
|
||||
, ncExam
|
||||
, ncExternalExam
|
||||
, verifySubmission
|
||||
, verifyCourseApplication
|
||||
, verifyCourseNews
|
||||
]
|
||||
where
|
||||
normalizeRender :: Route UniWorX -> WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX)) (Route UniWorX)
|
||||
normalizeRender route = route <$ do
|
||||
YesodRequest{..} <- liftHandler getRequest
|
||||
let original = (W.pathInfo reqWaiRequest, reqGetParams)
|
||||
rendered = renderRoute route
|
||||
if
|
||||
| (isSuffixOf `on` fst) original rendered -> do -- FIXME: this breaks when subsite prefixes are dynamic
|
||||
$logDebugS "normalizeRender" [st|#{tshow rendered} matches #{tshow original}|]
|
||||
| otherwise -> do
|
||||
$logDebugS "normalizeRender" [st|Redirecting because #{tshow rendered} does not match #{tshow original}|]
|
||||
tell $ Any True
|
||||
|
||||
maybeOrig :: (Route UniWorX -> MaybeT (WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX))) (Route UniWorX))
|
||||
-> Route UniWorX -> WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX)) (Route UniWorX)
|
||||
maybeOrig f route = maybeT (return route) $ f route
|
||||
|
||||
caseChanged :: (Eq a, Show a) => CI a -> CI a -> MaybeT (WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX))) ()
|
||||
caseChanged a b
|
||||
| ((/=) `on` CI.original) a b = do
|
||||
$logDebugS "routeNormalizers" [st|#{tshow a} /= #{tshow b}|]
|
||||
tell $ Any True
|
||||
| otherwise = return ()
|
||||
|
||||
ncSchool = maybeOrig . typesUsing @RouteChildren @SchoolId $ \ssh -> $cachedHereBinary ssh $ do
|
||||
let schoolShort :: SchoolShorthand
|
||||
schoolShort = unSchoolKey ssh
|
||||
Entity ssh' _ <- MaybeT . lift . getBy $ UniqueSchoolShorthand schoolShort
|
||||
(caseChanged `on` unSchoolKey) ssh ssh'
|
||||
return ssh'
|
||||
ncAllocation = maybeOrig $ \route -> do
|
||||
AllocationR tid ssh ash _ <- return route
|
||||
Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . lift . getBy $ TermSchoolAllocationShort tid ssh ash
|
||||
caseChanged ash allocationShorthand
|
||||
return $ route & typesUsing @RouteChildren @AllocationShorthand . filtered (== ash) .~ allocationShorthand
|
||||
ncCourse = maybeOrig $ \route -> do
|
||||
CourseR tid ssh csh _ <- return route
|
||||
Entity _ Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
caseChanged csh courseShorthand
|
||||
return $ route & typesUsing @RouteChildren @CourseShorthand . filtered (== csh) .~ courseShorthand
|
||||
ncSheet = maybeOrig $ \route -> do
|
||||
CSheetR tid ssh csh shn _ <- return route
|
||||
cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _ Sheet{..} <- MaybeT . $cachedHereBinary (cid, shn) . lift . getBy $ CourseSheet cid shn
|
||||
caseChanged shn sheetName
|
||||
return $ route & typesUsing @RouteChildren @SheetName . filtered (== shn) .~ sheetName
|
||||
ncMaterial = maybeOrig $ \route -> do
|
||||
CMaterialR tid ssh csh mnm _ <- return route
|
||||
cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _ Material{..} <- MaybeT . $cachedHereBinary (cid, mnm) . lift . getBy $ UniqueMaterial cid mnm
|
||||
caseChanged mnm materialName
|
||||
return $ route & typesUsing @RouteChildren @MaterialName . filtered (== mnm) .~ materialName
|
||||
ncTutorial = maybeOrig $ \route -> do
|
||||
CTutorialR tid ssh csh tutn _ <- return route
|
||||
cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _ Tutorial{..} <- MaybeT . $cachedHereBinary (cid, tutn) . lift . getBy $ UniqueTutorial cid tutn
|
||||
caseChanged tutn tutorialName
|
||||
return $ route & typesUsing @RouteChildren @TutorialName . filtered (== tutn) .~ tutorialName
|
||||
ncExam = maybeOrig $ \route -> do
|
||||
CExamR tid ssh csh examn _ <- return route
|
||||
cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _ Exam{..} <- MaybeT . $cachedHereBinary (cid, examn) . lift . getBy $ UniqueExam cid examn
|
||||
caseChanged examn examName
|
||||
return $ route & typesUsing @RouteChildren @ExamName . filtered (== examn) .~ examName
|
||||
ncExternalExam = maybeOrig $ \route -> do
|
||||
EExamR tid ssh coursen examn _ <- return route
|
||||
Entity _ ExternalExam{..} <- MaybeT . $cachedHereBinary (tid, ssh, coursen, examn) . lift . getBy $ UniqueExternalExam tid ssh coursen examn
|
||||
caseChanged coursen externalExamCourseName
|
||||
caseChanged examn externalExamExamName
|
||||
return $ route
|
||||
& typesUsing @RouteChildren @CourseName . filtered (== coursen) .~ externalExamCourseName
|
||||
& typesUsing @RouteChildren @ExamName . filtered (== examn) .~ externalExamExamName
|
||||
verifySubmission = maybeOrig $ \route -> do
|
||||
CSubmissionR _tid _ssh _csh _shn cID sr <- return route
|
||||
sId <- $cachedHereBinary cID $ decrypt cID
|
||||
Submission{submissionSheet} <- MaybeT . $cachedHereBinary cID . lift $ get sId
|
||||
Sheet{sheetCourse, sheetName} <- MaybeT . $cachedHereBinary submissionSheet . lift $ get submissionSheet
|
||||
Course{courseTerm, courseSchool, courseShorthand} <- MaybeT . $cachedHereBinary sheetCourse . lift $ get sheetCourse
|
||||
let newRoute = CSubmissionR courseTerm courseSchool courseShorthand sheetName cID sr
|
||||
tell . Any $ route /= newRoute
|
||||
return newRoute
|
||||
verifyCourseApplication = maybeOrig $ \route -> do
|
||||
CApplicationR _tid _ssh _csh cID sr <- return route
|
||||
aId <- decrypt cID
|
||||
CourseApplication{courseApplicationCourse} <- lift . lift $ get404 aId
|
||||
Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 courseApplicationCourse
|
||||
let newRoute = CApplicationR courseTerm courseSchool courseShorthand cID sr
|
||||
tell . Any $ route /= newRoute
|
||||
return newRoute
|
||||
verifyCourseNews = maybeOrig $ \route -> do
|
||||
CNewsR _tid _ssh _csh cID sr <- return route
|
||||
aId <- decrypt cID
|
||||
CourseNews{courseNewsCourse} <- lift . lift $ get404 aId
|
||||
Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 courseNewsCourse
|
||||
let newRoute = CNewsR courseTerm courseSchool courseShorthand cID sr
|
||||
tell . Any $ route /= newRoute
|
||||
return newRoute
|
||||
44
src/Foundation/Yesod/Persist.hs
Normal file
44
src/Foundation/Yesod/Persist.hs
Normal file
@ -0,0 +1,44 @@
|
||||
module Foundation.Yesod.Persist
|
||||
( runDB, getDBRunner
|
||||
, module Foundation.DB
|
||||
) where
|
||||
|
||||
import Import.NoFoundation hiding (runDB, getDBRunner)
|
||||
|
||||
import Foundation.Type
|
||||
import Foundation.DB
|
||||
import Foundation.Authorization
|
||||
|
||||
import Database.Persist.Sql (transactionUndo)
|
||||
|
||||
|
||||
runDB :: ( YesodPersistBackend UniWorX ~ SqlBackend
|
||||
, BearerAuthSite UniWorX
|
||||
)
|
||||
=> YesodDB UniWorX a -> HandlerFor UniWorX a
|
||||
runDB action = do
|
||||
-- stack <- liftIO currentCallStack
|
||||
-- $logDebugS "YesodPersist" . unlines $ "runDB" : map pack stack
|
||||
$logDebugS "YesodPersist" "runDB"
|
||||
dryRun <- isDryRun
|
||||
let action'
|
||||
| dryRun = action <* transactionUndo
|
||||
| otherwise = action
|
||||
|
||||
runSqlPoolRetry action' . appConnPool =<< getYesod
|
||||
|
||||
getDBRunner :: ( YesodPersistBackend UniWorX ~ SqlBackend
|
||||
, BearerAuthSite UniWorX
|
||||
)
|
||||
=> HandlerFor UniWorX (DBRunner UniWorX, HandlerFor UniWorX ())
|
||||
getDBRunner = do
|
||||
(DBRunner{..}, cleanup) <- defaultGetDBRunner appConnPool
|
||||
return . (, cleanup) $ DBRunner
|
||||
(\action -> do
|
||||
dryRun <- isDryRun
|
||||
let action'
|
||||
| dryRun = action <* transactionUndo
|
||||
| otherwise = action
|
||||
$logDebugS "YesodPersist" "runDBRunner"
|
||||
runDBRunner action'
|
||||
)
|
||||
62
src/Foundation/Yesod/Session.hs
Normal file
62
src/Foundation/Yesod/Session.hs
Normal file
@ -0,0 +1,62 @@
|
||||
module Foundation.Yesod.Session
|
||||
( makeSessionBackend
|
||||
) where
|
||||
|
||||
import Import.NoFoundation hiding (makeSessionBackend)
|
||||
|
||||
import Foundation.Type
|
||||
|
||||
import qualified Web.ServerSession.Core as ServerSession
|
||||
import qualified Web.ServerSession.Frontend.Yesod.Jwt as JwtSession
|
||||
|
||||
import qualified Network.Wai as W
|
||||
import qualified Network.HTTP.Types.Header as W
|
||||
import qualified Network.Wai.Middleware.HttpAuth as W (extractBearerAuth)
|
||||
|
||||
import Web.Cookie
|
||||
|
||||
|
||||
makeSessionBackend :: Yesod UniWorX => UniWorX -> IO (Maybe SessionBackend)
|
||||
makeSessionBackend app@UniWorX{ appSettings' = AppSettings{..}, ..} = notForBearer . sameSite $ case appSessionStore of
|
||||
SessionStorageMemcachedSql sqlStore
|
||||
-> mkBackend . stateSettings =<< ServerSession.createState sqlStore
|
||||
SessionStorageAcid acidStore
|
||||
| appServerSessionAcidFallback
|
||||
-> mkBackend . stateSettings =<< ServerSession.createState acidStore
|
||||
_other
|
||||
-> return Nothing
|
||||
where
|
||||
cfg = JwtSession.ServerSessionJwtConfig
|
||||
{ sJwtJwkSet = appJSONWebKeySet
|
||||
, sJwtStart = Nothing
|
||||
, sJwtExpiration = appSessionTokenExpiration
|
||||
, sJwtEncoding = appSessionTokenEncoding
|
||||
, sJwtIssueBy = appInstanceID
|
||||
, sJwtIssueFor = appClusterID
|
||||
}
|
||||
mkBackend :: forall sto.
|
||||
( ServerSession.SessionData sto ~ Map Text ByteString
|
||||
, ServerSession.Storage sto
|
||||
)
|
||||
=> ServerSession.State sto -> IO (Maybe SessionBackend)
|
||||
mkBackend = JwtSession.backend cfg (JwtSession.siteApproot app)
|
||||
stateSettings :: forall sto. ServerSession.State sto -> ServerSession.State sto
|
||||
stateSettings = ServerSession.setCookieName (toPathPiece CookieSession) . applyServerSessionSettings appServerSessionConfig
|
||||
sameSite
|
||||
| Just sameSiteStrict == cookieSameSite (getCookieSettings app CookieSession)
|
||||
= strictSameSiteSessions
|
||||
| Just sameSiteLax == cookieSameSite (getCookieSettings app CookieSession)
|
||||
= laxSameSiteSessions
|
||||
| otherwise
|
||||
= id
|
||||
notForBearer :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
|
||||
notForBearer = fmap $ fmap notForBearer'
|
||||
where notForBearer' :: SessionBackend -> SessionBackend
|
||||
notForBearer' (SessionBackend load)
|
||||
= let load' req
|
||||
| aHdrs <- mapMaybe (\(h, v) -> v <$ guard (h == W.hAuthorization)) $ W.requestHeaders req
|
||||
, any (is _Just . W.extractBearerAuth) aHdrs
|
||||
= return (mempty, const $ return [])
|
||||
| otherwise
|
||||
= load req
|
||||
in SessionBackend load'
|
||||
49
src/Foundation/Yesod/StaticContent.hs
Normal file
49
src/Foundation/Yesod/StaticContent.hs
Normal file
@ -0,0 +1,49 @@
|
||||
module Foundation.Yesod.StaticContent
|
||||
( addStaticContent
|
||||
) where
|
||||
|
||||
import Import.NoFoundation hiding (addStaticContent)
|
||||
|
||||
import Foundation.Type
|
||||
|
||||
import qualified Database.Memcached.Binary.IO as Memcached
|
||||
|
||||
import qualified Data.ByteString.Lazy as Lazy
|
||||
import qualified Data.ByteString.Base64.URL as Base64 (encodeUnpadded)
|
||||
import Data.ByteArray (convert)
|
||||
import Crypto.Hash (SHAKE256)
|
||||
import Crypto.Hash.Conduit (sinkHash)
|
||||
import Data.Bits (Bits(zeroBits))
|
||||
|
||||
import qualified Data.Conduit.Combinators as C
|
||||
|
||||
|
||||
addStaticContent :: Text
|
||||
-> Text
|
||||
-> Lazy.ByteString
|
||||
-> HandlerFor UniWorX (Maybe (Either Text (Route UniWorX, [(Text, Text)])))
|
||||
addStaticContent ext _mime content = do
|
||||
UniWorX{appWidgetMemcached, appSettings'} <- getYesod
|
||||
for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings') $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConf = MemcachedConf { memcachedExpiry }, widgetMemcachedBaseUrl }) -> do
|
||||
let expiry = maybe 0 ceiling memcachedExpiry
|
||||
touch = liftIO $ Memcached.touch expiry (encodeUtf8 $ pack fileName) mConn
|
||||
add = liftIO $ Memcached.add zeroBits expiry (encodeUtf8 $ pack fileName) content mConn
|
||||
absoluteLink = unpack widgetMemcachedBaseUrl </> fileName
|
||||
catchIf Memcached.isKeyNotFound touch . const $
|
||||
handleIf Memcached.isKeyExists (const $ return ()) add
|
||||
return . Left $ pack absoluteLink
|
||||
where
|
||||
-- Generate a unique filename based on the content itself, this is used
|
||||
-- for deduplication so a collision resistant hash function is required
|
||||
--
|
||||
-- SHA-3 (SHAKE256) seemed to be a future-proof choice
|
||||
--
|
||||
-- Length of hash is 144 bits ~~instead of MD5's 128, so as to avoid
|
||||
-- padding after base64-conversion~~ for backwards compatability
|
||||
fileName = (<.> unpack ext)
|
||||
. unpack
|
||||
. decodeUtf8
|
||||
. Base64.encodeUnpadded
|
||||
. (convert :: Digest (SHAKE256 144) -> ByteString)
|
||||
. runConduitPure
|
||||
$ C.sourceLazy content .| sinkHash
|
||||
@ -4,8 +4,6 @@ module Handler.Admin
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
|
||||
import Handler.Admin.Test as Handler.Admin
|
||||
import Handler.Admin.ErrorMessage as Handler.Admin
|
||||
import Handler.Admin.StudyFeatures as Handler.Admin
|
||||
|
||||
@ -88,7 +88,7 @@ postAdminTokensR = do
|
||||
|
||||
fmap Just . encodeBearer . set _bearerRestrictions btfRestrict =<< bearerToken btfAuthority' btfRoutes btfAddAuth btfExpiresAt btfStartsAt
|
||||
|
||||
siteLayoutMsg' MsgMenuAdminTokens $ do
|
||||
siteLayoutMsg MsgMenuAdminTokens $ do
|
||||
setTitleI MsgMenuAdminTokens
|
||||
|
||||
let bearerForm = wrapForm bearerView def
|
||||
|
||||
@ -5,6 +5,8 @@ module Handler.CryptoIDDispatch
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
|
||||
import qualified Data.Text as Text
|
||||
|
||||
import Yesod.Core.Types (HandlerContents(..))
|
||||
@ -45,7 +47,7 @@ instance CryptoRoute UUID UserId where
|
||||
(_ :: UserId) <- decrypt cID
|
||||
return $ AdminUserR cID
|
||||
|
||||
class Dispatch ciphertext (x :: [*]) where
|
||||
class Dispatch ciphertext (x :: [Type]) where
|
||||
dispatchID :: p x -> ciphertext -> Handler (Maybe (Route UniWorX))
|
||||
|
||||
instance Dispatch ciphertext '[] where
|
||||
|
||||
@ -23,7 +23,7 @@ getVersionR = selectRep $ do
|
||||
-- | Datenschutzerklaerung und Aufbewahrungspflichten, Nutzungsbedingungen, Urheberrecht, Impressum
|
||||
getLegalR :: Handler Html
|
||||
getLegalR =
|
||||
siteLayoutMsg' MsgMenuLegal $ do
|
||||
siteLayoutMsg MsgMenuLegal $ do
|
||||
setTitleI MsgLegalHeading
|
||||
let dataProtection = $(i18nWidgetFile "data-protection")
|
||||
termsUse = $(i18nWidgetFile "terms-of-use")
|
||||
@ -48,7 +48,7 @@ getInfoR = -- do
|
||||
|
||||
getInfoLecturerR :: Handler Html
|
||||
getInfoLecturerR =
|
||||
siteLayoutMsg' MsgInfoLecturerTitle $ do
|
||||
siteLayoutMsg MsgInfoLecturerTitle $ do
|
||||
setTitleI MsgInfoLecturerTitle
|
||||
$(i18nWidgetFile "info-lecturer")
|
||||
where
|
||||
@ -76,7 +76,7 @@ getInfoLecturerR =
|
||||
|
||||
getGlossaryR :: Handler Html
|
||||
getGlossaryR =
|
||||
siteLayoutMsg' MsgGlossaryTitle $ do
|
||||
siteLayoutMsg MsgGlossaryTitle $ do
|
||||
setTitleI MsgGlossaryTitle
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
let
|
||||
@ -137,7 +137,7 @@ faqsWidget mLimit route = do
|
||||
|
||||
getFaqR :: Handler Html
|
||||
getFaqR =
|
||||
siteLayoutMsg' MsgFaqTitle $ do
|
||||
siteLayoutMsg MsgFaqTitle $ do
|
||||
setTitleI MsgFaqTitle
|
||||
|
||||
fromMaybe mempty . view _1 =<< faqsWidget Nothing Nothing
|
||||
|
||||
@ -28,6 +28,8 @@ import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Jobs
|
||||
|
||||
import Foundation.Yesod.Auth (updateUserLanguage)
|
||||
|
||||
|
||||
data SettingsForm = SettingsForm
|
||||
{ stgDisplayName :: UserDisplayName
|
||||
|
||||
@ -6,8 +6,6 @@ module Handler.Sheet
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
|
||||
|
||||
import Handler.Sheet.CorrectorInvite as Handler.Sheet (getSCorrInviteR, postSCorrInviteR)
|
||||
import Handler.Sheet.Delete as Handler.Sheet
|
||||
|
||||
@ -5,6 +5,7 @@ module Handler.Sheet.Current
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
import Utils.Sheet
|
||||
|
||||
|
||||
|
||||
@ -25,6 +25,8 @@ import Handler.Submission.Create
|
||||
import Handler.Submission.Grade
|
||||
import Handler.Submission.Upload
|
||||
|
||||
import Handler.Utils
|
||||
|
||||
|
||||
import Import
|
||||
|
||||
|
||||
@ -157,3 +157,21 @@ studyFeaturesWidget featId = do
|
||||
|
||||
getShowSex :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool
|
||||
getShowSex = maybe False (userShowSex . entityVal) <$> maybeAuth
|
||||
|
||||
|
||||
-- | Conditional redirect that hides the URL if the user is not authorized for the route
|
||||
redirectAccess :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
|
||||
redirectAccess url = liftHandler $ do
|
||||
-- must hide URL if not authorized
|
||||
access <- isAuthorized url False
|
||||
case access of
|
||||
Authorized -> redirect url
|
||||
_ -> permissionDeniedI MsgUnauthorizedRedirect
|
||||
|
||||
redirectAccessWith :: (MonadHandler m, HandlerSite m ~ UniWorX) => Status -> Route (HandlerSite m) -> m a
|
||||
redirectAccessWith status url = liftHandler $ do
|
||||
-- must hide URL if not authorized
|
||||
access <- isAuthorized url False
|
||||
case access of
|
||||
Authorized -> redirectWith status url
|
||||
_ -> permissionDeniedI MsgUnauthorizedRedirect
|
||||
|
||||
@ -15,8 +15,6 @@ import Handler.Utils.Pandoc
|
||||
|
||||
import Handler.Utils.DateTime
|
||||
|
||||
import Handler.Utils.Widgets
|
||||
|
||||
import Handler.Utils.I18n
|
||||
|
||||
import Handler.Utils.Files
|
||||
|
||||
@ -6,6 +6,7 @@ module Handler.Utils.Form.MassInput.Liveliness
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
import Data.Kind (Type)
|
||||
|
||||
import Web.PathPieces (PathPiece)
|
||||
import Data.Aeson (ToJSON, FromJSON, ToJSONKey, FromJSONKey)
|
||||
@ -38,7 +39,7 @@ boxDimension n
|
||||
-- zeroDimension (boxDimension -> BoxDimension dim) = set dim $ boxOrigin ^. dim
|
||||
|
||||
class (IsBoxCoord (BoxCoord a), Lattice a, BoundedJoinSemiLattice a) => Liveliness a where
|
||||
type BoxCoord a :: *
|
||||
type BoxCoord a :: Type
|
||||
liveCoords :: Prism' (Set (BoxCoord a)) a
|
||||
liveCoord :: BoxCoord a -> Prism' Bool a
|
||||
liveCoord bC = prism' (\l -> bC `Set.member` review liveCoords l) (bool (Just bottom) (preview liveCoords $ Set.singleton bC))
|
||||
|
||||
@ -44,19 +44,19 @@ class ( PersistRecordBackend junction (YesodPersistBackend UniWorX)
|
||||
, Typeable junction
|
||||
) => IsInvitableJunction junction where
|
||||
-- | One side of the junction is always `User`; `InvitationFor junction` is the other
|
||||
type InvitationFor junction :: *
|
||||
type InvitationFor junction :: Type
|
||||
-- | `junction` without `Key User` and `Key (InvitationFor junction)`
|
||||
data InvitableJunction junction :: *
|
||||
data InvitableJunction junction :: Type
|
||||
|
||||
-- | `InvitationData` is all data associated with an invitation except for the `UserEmail` and `InvitationFor junction`
|
||||
--
|
||||
-- Note that this is only the data associated with the invitation; some user input might still be required to construct `InvitableJunction junction`
|
||||
type InvitationData junction = (dat :: *) | dat -> junction
|
||||
type InvitationData junction = (dat :: Type) | dat -> junction
|
||||
type InvitationData junction = (InvitationDBData junction, InvitationTokenData junction)
|
||||
-- | `InvitationDBData` is the part of `InvitationData` that is stored confidentially in the database
|
||||
data InvitationDBData junction :: *
|
||||
data InvitationDBData junction :: Type
|
||||
-- | `InvitationTokenData` is the part of `InvitationData` that is stored readably within the token
|
||||
data InvitationTokenData junction :: *
|
||||
data InvitationTokenData junction :: Type
|
||||
|
||||
_InvitableJunction :: Iso' junction (UserId, Key (InvitationFor junction), InvitableJunction junction)
|
||||
|
||||
|
||||
@ -30,7 +30,7 @@ import Crypto.Hash.Algorithms (SHAKE256)
|
||||
|
||||
import qualified Data.ByteArray as BA
|
||||
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH hiding (Type)
|
||||
|
||||
import Data.Typeable (typeRep)
|
||||
import Type.Reflection (typeOf, TypeRep)
|
||||
@ -52,7 +52,7 @@ import qualified Crypto.Saltine.Core.AEAD as AEAD
|
||||
import qualified Control.Monad.State.Class as State
|
||||
|
||||
|
||||
type Expiry = (Either UTCTime DiffTime)
|
||||
type Expiry = Either UTCTime DiffTime
|
||||
|
||||
_MemcachedExpiry :: Prism' Expiry Memcached.Expiry
|
||||
_MemcachedExpiry = prism' fromExpiry toExpiry
|
||||
@ -169,7 +169,7 @@ memcachedSet :: ( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
=> Maybe Expiry -> a -> m ()
|
||||
memcachedSet mExp = memcachedBySet mExp () . MemcachedUnkeyed
|
||||
|
||||
memcachedInvalidate :: forall (a :: *) m p.
|
||||
memcachedInvalidate :: forall (a :: Type) m p.
|
||||
( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, Typeable a
|
||||
)
|
||||
|
||||
@ -54,7 +54,6 @@ import Handler.Utils.Form
|
||||
import Handler.Utils.Csv
|
||||
import Handler.Utils.ContentDisposition
|
||||
import Handler.Utils.I18n
|
||||
import Handler.Utils.Widgets
|
||||
import Utils
|
||||
import Utils.Lens
|
||||
|
||||
@ -665,12 +664,12 @@ simpleCsvEncodeM fName f = Just DBTCsvEncode
|
||||
}
|
||||
|
||||
|
||||
class (MonadHandler m, HandlerSite m ~ UniWorX, Monoid' x, Monoid' (DBCell m x), Default (DBParams m x)) => IsDBTable (m :: * -> *) (x :: *) where
|
||||
data DBParams m x :: *
|
||||
type DBResult m x :: *
|
||||
-- type DBResult' m x :: *
|
||||
class (MonadHandler m, HandlerSite m ~ UniWorX, Monoid' x, Monoid' (DBCell m x), Default (DBParams m x)) => IsDBTable (m :: Type -> Type) (x :: Type) where
|
||||
data DBParams m x :: Type
|
||||
type DBResult m x :: Type
|
||||
-- type DBResult' m x :: Type
|
||||
|
||||
data DBCell m x :: *
|
||||
data DBCell m x :: Type
|
||||
dbCell :: Iso' (DBCell m x) ([(Text, Text)], WriterT x m Widget)
|
||||
|
||||
-- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x)
|
||||
|
||||
@ -10,6 +10,7 @@ module Handler.Utils.Users
|
||||
|
||||
import Import
|
||||
import Auth.LDAP (campusUserMatr')
|
||||
import Foundation.Yesod.Auth (upsertCampusUser)
|
||||
|
||||
import Crypto.Hash (hashlazy)
|
||||
|
||||
|
||||
@ -148,12 +148,6 @@ invDualCoHeat :: ( Real a, Real b, Real c )
|
||||
-- ^ Distinguishes @full@, zero is mapped to 2, @optimal@ is mapped to 1, @full@ is mapped to 0
|
||||
invDualCoHeat optimal full achieved = 2 - dualCoHeat optimal full achieved
|
||||
|
||||
i18n :: forall m msg.
|
||||
( MonadWidget m
|
||||
, RenderMessage (HandlerSite m) msg
|
||||
) => msg -> m ()
|
||||
i18n = toWidget . (SomeMessage :: msg -> SomeMessage (HandlerSite m))
|
||||
|
||||
|
||||
examOccurrenceMappingDescriptionWidget :: ExamOccurrenceRule -> Set ExamOccurrenceMappingDescription -> Widget
|
||||
examOccurrenceMappingDescriptionWidget rule descriptions = $(widgetFile "widgets/exam-occurrence-mapping-description")
|
||||
|
||||
@ -39,6 +39,7 @@ import Utils as Import
|
||||
import Utils.Frontend.I18n as Import
|
||||
import Utils.DB as Import
|
||||
import Utils.Sql as Import
|
||||
import Utils.Widgets as Import
|
||||
|
||||
import Data.Fixed as Import
|
||||
|
||||
@ -170,6 +171,7 @@ import Network.Minio.Instances as Import ()
|
||||
import System.Clock.Instances as Import ()
|
||||
import Data.Word.Word24.Instances as Import ()
|
||||
import Control.Monad.Trans.Memo.StateCache.Instances as Import (hoistStateCache)
|
||||
import Database.Persist.Sql.Types.Instances as Import ()
|
||||
|
||||
import Crypto.Hash as Import (Digest, SHA3_256, SHA3_512)
|
||||
import Crypto.Random as Import (ChaChaDRG, Seed)
|
||||
@ -192,6 +194,8 @@ import GHC.TypeLits as Import (KnownSymbol)
|
||||
|
||||
import Data.Word.Word24 as Import
|
||||
|
||||
import Data.Kind as Import (Type, Constraint)
|
||||
|
||||
|
||||
import Control.Monad.Trans.RWS (RWST)
|
||||
|
||||
|
||||
@ -8,6 +8,7 @@ import Import
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
import Auth.LDAP
|
||||
import Foundation.Yesod.Auth (CampusUserConversionException, upsertCampusUser)
|
||||
|
||||
import Jobs.Queue
|
||||
|
||||
|
||||
@ -38,6 +38,8 @@ module Mail
|
||||
|
||||
import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender, derivePersistFieldJSON)
|
||||
|
||||
import Data.Kind (Type)
|
||||
|
||||
import Model.Types.Languages
|
||||
|
||||
import Network.Mail.Mime hiding (addPart, addAttachment)
|
||||
@ -325,7 +327,7 @@ instance Monoid (PrioritisedAlternatives m) where
|
||||
mappend = (<>)
|
||||
|
||||
class YesodMail site => ToMailPart site a where
|
||||
type MailPartReturn site a :: *
|
||||
type MailPartReturn site a :: Type
|
||||
type MailPartReturn site a = ()
|
||||
toMailPart :: (MonadMail m, HandlerSite m ~ site) => a -> StateT Part m (MailPartReturn site a)
|
||||
|
||||
|
||||
@ -28,7 +28,7 @@ makeLenses_ ''FileReference
|
||||
|
||||
|
||||
class HasFileReference record where
|
||||
data FileReferenceResidual record :: *
|
||||
data FileReferenceResidual record :: Type
|
||||
|
||||
_FileReference :: Iso' record (FileReference, FileReferenceResidual record)
|
||||
|
||||
|
||||
@ -587,3 +587,10 @@ compileTimeAppSettings =
|
||||
case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of
|
||||
Aeson.Error e -> error e
|
||||
Aeson.Success settings -> settings
|
||||
|
||||
|
||||
getTimeLocale' :: [Lang] -> TimeLocale
|
||||
getTimeLocale' = $(timeLocaleMap [("de-de", "de_DE.utf8"), ("en-GB", "en_GB.utf8")])
|
||||
|
||||
appTZ :: TZ
|
||||
appTZ = $(includeSystemTZ "Europe/Berlin")
|
||||
|
||||
@ -8,6 +8,8 @@ module Settings.Cluster
|
||||
import ClassyPrelude.Yesod
|
||||
import Web.HttpApiData
|
||||
|
||||
import Data.Kind (Type)
|
||||
|
||||
import Utils
|
||||
import Data.Universe
|
||||
|
||||
@ -59,7 +61,7 @@ instance FromHttpApiData ClusterSettingsKey where
|
||||
|
||||
|
||||
class (ToJSON (ClusterSettingValue key), FromJSON (ClusterSettingValue key)) => ClusterSetting (key :: ClusterSettingsKey) where
|
||||
type ClusterSettingValue key :: *
|
||||
type ClusterSettingValue key :: Type
|
||||
initClusterSetting :: forall m p. MonadIO m => p key -> m (ClusterSettingValue key)
|
||||
knownClusterSetting :: forall p. p key -> ClusterSettingsKey
|
||||
|
||||
|
||||
@ -183,7 +183,6 @@ instance HasContentType YamlValue where
|
||||
toYAML :: ToJSON a => a -> YamlValue
|
||||
toYAML = YamlValue . toJSON
|
||||
|
||||
|
||||
---------------------
|
||||
-- Text and String --
|
||||
---------------------
|
||||
|
||||
@ -24,51 +24,51 @@ emptyOrIn criterion testSet
|
||||
entities2map :: PersistEntity record => [Entity record] -> Map (Key record) record
|
||||
entities2map = foldl' (\m entity -> Map.insert (entityKey entity) (entityVal entity) m) Map.empty
|
||||
|
||||
getJustBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m, MonadThrow m, Show (Unique record))
|
||||
getJustBy :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadIO m, MonadThrow m, Show (Unique record))
|
||||
=> Unique record -> ReaderT backend m (Entity record)
|
||||
getJustBy u = getBy u >>= maybe
|
||||
(throwM . PersistForeignConstraintUnmet $ tshow u)
|
||||
return
|
||||
|
||||
getKeyBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
|
||||
getKeyBy :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadIO m)
|
||||
=> Unique record -> ReaderT backend m (Maybe (Key record))
|
||||
getKeyBy u = fmap entityKey <$> getBy u -- TODO optimize this, so that DB does not deliver entire record!
|
||||
|
||||
getKeyJustBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m, MonadThrow m, Show (Unique record))
|
||||
getKeyJustBy :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadIO m, MonadThrow m, Show (Unique record))
|
||||
=> Unique record -> ReaderT backend m (Key record)
|
||||
getKeyJustBy u = getKeyBy u >>= maybe
|
||||
(throwM . PersistForeignConstraintUnmet $ tshow u)
|
||||
return
|
||||
|
||||
getKeyBy404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadHandler m)
|
||||
getKeyBy404 :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadHandler m)
|
||||
=> Unique record -> ReaderT backend m (Key record)
|
||||
getKeyBy404 u = getKeyBy u >>= maybe notFound return
|
||||
|
||||
getEntity404 :: (PersistStoreRead backend, PersistRecordBackend val backend, MonadHandler m)
|
||||
=> Key val -> ReaderT backend m (Entity val)
|
||||
getEntity404 :: (PersistStoreRead backend, PersistRecordBackend record backend, MonadHandler m)
|
||||
=> Key record -> ReaderT backend m (Entity record)
|
||||
getEntity404 k = Entity k <$> get404 k
|
||||
|
||||
existsBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
|
||||
existsBy :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadIO m)
|
||||
=> Unique record -> ReaderT backend m Bool
|
||||
existsBy = fmap (is _Just) . getKeyBy
|
||||
|
||||
existsBy404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadHandler m)
|
||||
existsBy404 :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadHandler m)
|
||||
=> Unique record -> ReaderT backend m ()
|
||||
existsBy404 = bool notFound (return ()) <=< fmap (is _Just) . getKeyBy
|
||||
|
||||
existsKey :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistQueryRead backend, MonadIO m)
|
||||
existsKey :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m)
|
||||
=> Key record -> ReaderT backend m Bool
|
||||
existsKey = exists . pure . (persistIdField ==.)
|
||||
|
||||
exists :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistQueryRead backend, MonadIO m)
|
||||
exists :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m)
|
||||
=> [Filter record] -> ReaderT backend m Bool
|
||||
exists = fmap (not . null) . flip selectKeysList [LimitTo 1]
|
||||
|
||||
exists404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistQueryRead backend, MonadHandler m)
|
||||
exists404 :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadHandler m)
|
||||
=> [Filter record] -> ReaderT backend m ()
|
||||
exists404 = bool (return ()) notFound <=< fmap null . flip selectKeysList [LimitTo 1]
|
||||
|
||||
existsKey404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistQueryRead backend, MonadHandler m)
|
||||
existsKey404 :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadHandler m)
|
||||
=> Key record -> ReaderT backend m ()
|
||||
existsKey404 = bool notFound (return ()) <=< existsKey
|
||||
|
||||
|
||||
@ -5,6 +5,7 @@
|
||||
module Utils.Form where
|
||||
|
||||
import ClassyPrelude.Yesod hiding (addMessage, addMessageI, cons, Proxy(..), identifyForm, addClass, mreq, areq, wreq)
|
||||
import Data.Kind (Type)
|
||||
import qualified Yesod.Form.Functions as Yesod
|
||||
import Yesod.Core.Instances ()
|
||||
import Settings
|
||||
@ -275,7 +276,7 @@ identifyForm = identifyForm' id
|
||||
-- Buttons (new version ) --
|
||||
----------------------------
|
||||
|
||||
data family ButtonClass site :: *
|
||||
data family ButtonClass site :: Type
|
||||
|
||||
class (PathPiece a, PathPiece (ButtonClass site), RenderMessage site ButtonMessage) => Button site a where
|
||||
btnLabel :: a -> WidgetT site IO ()
|
||||
|
||||
@ -6,11 +6,11 @@ import qualified Data.List.NonEmpty as NonEmpty
|
||||
import Data.List (findIndex)
|
||||
|
||||
|
||||
getSystemMessage :: MonadHandler m
|
||||
getSystemMessage :: (MonadHandler m, BackendCompatible SqlReadBackend backend)
|
||||
=> NonEmpty Lang -- ^ `appLanguages`
|
||||
-> SystemMessageId
|
||||
-> ReaderT SqlBackend m (Maybe (SystemMessage, Maybe SystemMessageTranslation))
|
||||
getSystemMessage appLanguages smId = runMaybeT $ do
|
||||
-> ReaderT backend m (Maybe (SystemMessage, Maybe SystemMessageTranslation))
|
||||
getSystemMessage appLanguages smId = withReaderT (projectBackend @SqlReadBackend) . runMaybeT $ do
|
||||
SystemMessage{..} <- MaybeT $ get smId
|
||||
translations <- lift $ selectList [SystemMessageTranslationMessage ==. smId] []
|
||||
let
|
||||
|
||||
13
src/Utils/Widgets.hs
Normal file
13
src/Utils/Widgets.hs
Normal file
@ -0,0 +1,13 @@
|
||||
module Utils.Widgets
|
||||
( i18n
|
||||
) where
|
||||
|
||||
import ClassyPrelude.Yesod
|
||||
import Yesod.Core.Types.Instances ()
|
||||
|
||||
|
||||
i18n :: forall m msg.
|
||||
( MonadWidget m
|
||||
, RenderMessage (HandlerSite m) msg
|
||||
) => msg -> m ()
|
||||
i18n = toWidget . (SomeMessage :: msg -> SomeMessage (HandlerSite m))
|
||||
@ -120,6 +120,8 @@ extra-deps:
|
||||
|
||||
# - base64-bytestring-1.1.0.0
|
||||
|
||||
- generic-lens-1.2.0.0
|
||||
|
||||
- acid-state-0.16.0.1@sha256:d43f6ee0b23338758156c500290c4405d769abefeb98e9bc112780dae09ece6f,6207
|
||||
- bytebuild-0.3.6.0@sha256:aec785c906db5c7ec730754683196eb99a0d48e0deff7d4034c7b58307040b85,2982
|
||||
- byteslice-0.2.3.0@sha256:3ebcc77f8ac9fec3ca1a8304e66cfe0a1590c9272b768f2b19637e06de00bf6d,2014
|
||||
@ -154,4 +156,5 @@ extra-deps:
|
||||
- hlint-test-0.1.0.0@sha256:e427c0593433205fc629fb05b74c6b1deb1de72d1571f26142de008f0d5ee7a9,1814
|
||||
|
||||
resolver: nightly-2020-08-08
|
||||
compiler: ghc-8.10.2
|
||||
allow-newer: true
|
||||
|
||||
@ -164,6 +164,13 @@ packages:
|
||||
original:
|
||||
git: git@gitlab2.rz.ifi.lmu.de:uni2work/minio-hs.git
|
||||
commit: 42103ab247057c04c8ce7a83d9d4c160713a3df1
|
||||
- completed:
|
||||
hackage: generic-lens-1.2.0.0@sha256:b19e7970c93743a46bc3702331512a96d163de4356472f2d51a2945887aefe8c,6524
|
||||
pantry-tree:
|
||||
size: 4315
|
||||
sha256: 9ed161eadfda5b1eb36cfcf077146f7b66db1da69f1041fc720aea287ec021b0
|
||||
original:
|
||||
hackage: generic-lens-1.2.0.0
|
||||
- completed:
|
||||
hackage: acid-state-0.16.0.1@sha256:d43f6ee0b23338758156c500290c4405d769abefeb98e9bc112780dae09ece6f,6207
|
||||
pantry-tree:
|
||||
|
||||
@ -5,6 +5,8 @@ module ModelSpec where
|
||||
|
||||
import TestImport
|
||||
|
||||
import Settings (getTimeLocale')
|
||||
|
||||
import Model.TypesSpec ()
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
Loading…
Reference in New Issue
Block a user