Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX
This commit is contained in:
SJost
commit
45a71cc038
@ -13,9 +13,12 @@ detailed-logging: "_env:DETAILED_LOGGING:false"
|
||||
should-log-all: "_env:LOG_ALL:false"
|
||||
minimum-log-level: "_env:LOGLEVEL:warn"
|
||||
auth-dummy-login: "_env:DUMMY_LOGIN:false"
|
||||
auth-pwfile: "_env:PWFILE:"
|
||||
allow-deprecated: "_env:ALLOW_DEPRECATED:false"
|
||||
|
||||
auth-pw-hash:
|
||||
algorithm: "pbkdf2"
|
||||
strength: 14
|
||||
|
||||
# Optional values with the following production defaults.
|
||||
# In development, they default to true.
|
||||
# reload-templates: false
|
||||
@ -42,7 +45,7 @@ ldap:
|
||||
timeout: "_env:LDAPTIMEOUT:5"
|
||||
|
||||
user-defaults:
|
||||
favourites: 12
|
||||
max-favourites: 12
|
||||
theme: Default
|
||||
date-time-format: "%a %d %b %Y %R"
|
||||
date-format: "%d.%m.%Y"
|
||||
|
||||
20
db.hs
20
db.hs
@ -66,8 +66,8 @@ fillDb = do
|
||||
winter2017 = TermIdentifier 2017 Winter
|
||||
summer2018 = TermIdentifier 2018 Summer
|
||||
gkleen <- insert User
|
||||
{ userPlugin = "LDAP"
|
||||
, userIdent = "G.Kleen@campus.lmu.de"
|
||||
{ userIdent = "G.Kleen@campus.lmu.de"
|
||||
, userAuthentication = AuthLDAP
|
||||
, userMatrikelnummer = Nothing
|
||||
, userEmail = "G.Kleen@campus.lmu.de"
|
||||
, userDisplayName = "Gregor Kleen"
|
||||
@ -80,8 +80,8 @@ fillDb = do
|
||||
, userDownloadFiles = userDefaultDownloadFiles
|
||||
}
|
||||
fhamann <- insert User
|
||||
{ userPlugin = "LDAP"
|
||||
, userIdent = "felix.hamann@campus.lmu.de"
|
||||
{ userIdent = "felix.hamann@campus.lmu.de"
|
||||
, userAuthentication = AuthLDAP
|
||||
, userMatrikelnummer = Nothing
|
||||
, userEmail = "felix.hamann@campus.lmu.de"
|
||||
, userDisplayName = "Felix Hamann"
|
||||
@ -94,8 +94,8 @@ fillDb = do
|
||||
, userDownloadFiles = userDefaultDownloadFiles
|
||||
}
|
||||
jost <- insert User
|
||||
{ userPlugin = "LDAP"
|
||||
, userIdent = "jost@tcs.ifi.lmu.de"
|
||||
{ userIdent = "jost@tcs.ifi.lmu.de"
|
||||
, userAuthentication = AuthLDAP
|
||||
, userMatrikelnummer = Nothing
|
||||
, userEmail = "jost@tcs.ifi.lmu.de"
|
||||
, userDisplayName = "Steffen Jost"
|
||||
@ -108,8 +108,8 @@ fillDb = do
|
||||
, userDownloadFiles = userDefaultDownloadFiles
|
||||
}
|
||||
void . insert $ User
|
||||
{ userPlugin = "LDAP"
|
||||
, userIdent = "max@campus.lmu.de"
|
||||
{ userIdent = "max@campus.lmu.de"
|
||||
, userAuthentication = AuthLDAP
|
||||
, userMatrikelnummer = Nothing
|
||||
, userEmail = "max@campus.lmu.de"
|
||||
, userDisplayName = "Max Musterstudent"
|
||||
@ -122,8 +122,8 @@ fillDb = do
|
||||
, userDownloadFiles = userDefaultDownloadFiles
|
||||
}
|
||||
void . insert $ User
|
||||
{ userPlugin = "LDAP"
|
||||
, userIdent = "tester@campus.lmu.de"
|
||||
{ userIdent = "tester@campus.lmu.de"
|
||||
, userAuthentication = AuthLDAP
|
||||
, userMatrikelnummer = Just "999"
|
||||
, userEmail = "tester@campus.lmu.de"
|
||||
, userDisplayName = "Tina Tester"
|
||||
|
||||
1
messages/dummy/de.msg
Normal file
1
messages/dummy/de.msg
Normal file
@ -0,0 +1 @@
|
||||
DummyIdent: Nutzer-Kennung
|
||||
2
messages/pw-hash/de.msg
Normal file
2
messages/pw-hash/de.msg
Normal file
@ -0,0 +1,2 @@
|
||||
PWHashIdent: Identifikation
|
||||
PWHashPassword: Passwort
|
||||
@ -201,7 +201,7 @@ MatrikelNr: Matrikelnummer
|
||||
Theme: Oberflächen Design
|
||||
Favoriten: Anzahl gespeicherter Favoriten
|
||||
Plugin: Plugin
|
||||
Ident: Identifizierung
|
||||
Ident: Identifikation
|
||||
Settings: Individuelle Benutzereinstellungen
|
||||
SettingsUpdate: Einstellungen wurden gespeichert.
|
||||
|
||||
@ -288,6 +288,8 @@ SubmissionFilesIgnored: Es wurden Dateien in der hochgeladenen Abgabe ignoriert:
|
||||
SubmissionDoesNotExist smid@CryptoFileNameSubmission: Es existiert keine Abgabe mit Nummer #{toPathPiece smid}.
|
||||
|
||||
LDAPLoginTitle: Campus-Login
|
||||
PWHashLoginTitle: Uni2Work-Login
|
||||
PWHashLoginNote: Dieses Formular ist zu verwenden, wenn Sie vom Uni2Work-Team spezielle Logindaten erhalten haben. Normale Nutzer melden sich bitte via Campus-Login an!
|
||||
DummyLoginTitle: Development-Login
|
||||
|
||||
CorrectorNormal: Normal
|
||||
|
||||
6
models
6
models
@ -1,6 +1,6 @@
|
||||
User json
|
||||
plugin Text
|
||||
ident Text
|
||||
ident (CI Text)
|
||||
authentication AuthenticationMode
|
||||
matrikelnummer Text Maybe
|
||||
email (CI Text)
|
||||
displayName Text
|
||||
@ -11,7 +11,7 @@ User json
|
||||
dateFormat DateTimeFormat "default='%d.%m.%Y'"
|
||||
timeFormat DateTimeFormat "default='%R'"
|
||||
downloadFiles Bool default=false
|
||||
UniqueAuthentication plugin ident
|
||||
UniqueAuthentication ident
|
||||
UniqueEmail email
|
||||
deriving Show
|
||||
UserAdmin
|
||||
|
||||
@ -206,13 +206,10 @@ handler h = getAppDevSettings >>= makeFoundation >>= flip unsafeHandler h
|
||||
db :: ReaderT SqlBackend (HandlerT UniWorX IO) a -> IO a
|
||||
db = handler . runDB
|
||||
|
||||
addPWEntry :: FilePath {-^ Password file -}
|
||||
-> User
|
||||
addPWEntry :: User
|
||||
-> Text {-^ Password -}
|
||||
-> IO ()
|
||||
addPWEntry pwFile User{..} (Text.encodeUtf8 -> pw) = do
|
||||
(Text.decodeUtf8 -> pwHash) <- makePassword pw 14
|
||||
let pwEntry = PWEntry{ pwUser = User{ userPlugin = "PWFile", .. }, .. }
|
||||
newUser = userIdent
|
||||
c <- either (const []) id <$> Yaml.decodeFileEither pwFile
|
||||
Yaml.encodeFile pwFile $ pwEntry : [ c' | c'@(PWEntry{pwUser=User{..}}) <- c, userIdent /= newUser ]
|
||||
addPWEntry User{..} (Text.encodeUtf8 -> pw) = db $ do
|
||||
PWHashConf{..} <- getsYesod $ appAuthPWHash . appSettings
|
||||
(AuthPWHash . Text.decodeUtf8 -> userAuthentication) <- liftIO $ makePasswordWith pwHashAlgorithm pw pwHashStrength
|
||||
void $ insert User{..}
|
||||
|
||||
63
src/Auth/Dummy.hs
Normal file
63
src/Auth/Dummy.hs
Normal file
@ -0,0 +1,63 @@
|
||||
{-# LANGUAGE NoImplicitPrelude
|
||||
, RecordWildCards
|
||||
, TemplateHaskell
|
||||
, FlexibleContexts
|
||||
, TypeFamilies
|
||||
, OverloadedStrings
|
||||
#-}
|
||||
|
||||
module Auth.Dummy
|
||||
( dummyLogin
|
||||
, DummyMessage(..)
|
||||
) where
|
||||
|
||||
import Import.NoFoundation
|
||||
import Database.Persist.Sql (SqlBackendCanRead)
|
||||
|
||||
import Utils.Form
|
||||
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
|
||||
data DummyMessage = MsgDummyIdent
|
||||
|
||||
|
||||
dummyForm :: ( RenderMessage site FormMessage
|
||||
, RenderMessage site DummyMessage
|
||||
, YesodPersist site
|
||||
, SqlBackendCanRead (YesodPersistBackend site)
|
||||
, Button site SubmitButton
|
||||
, Show (ButtonCssClass site)
|
||||
) => AForm (HandlerT site IO) (CI Text)
|
||||
dummyForm = areq (selectField userList) (fslI MsgDummyIdent) Nothing
|
||||
<* submitButton
|
||||
where
|
||||
userList = fmap mkOptionList . runDB $ map toOption <$> selectList [] [Asc UserIdent]
|
||||
toOption (Entity _ User{..}) = Option (CI.original userIdent) userIdent (CI.original userIdent)
|
||||
|
||||
dummyLogin :: ( YesodAuth site
|
||||
, YesodPersist site
|
||||
, SqlBackendCanRead (YesodPersistBackend site)
|
||||
, RenderMessage site FormMessage
|
||||
, RenderMessage site DummyMessage
|
||||
, Button site SubmitButton
|
||||
, Show (ButtonCssClass site)
|
||||
) => AuthPlugin site
|
||||
dummyLogin = AuthPlugin{..}
|
||||
where
|
||||
apName = "dummy"
|
||||
-- apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent
|
||||
apDispatch "POST" [] = do
|
||||
((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard dummyForm
|
||||
case loginRes of
|
||||
FormFailure errs -> do
|
||||
lift . forM_ errs $ addMessage Error . toHtml
|
||||
redirect LoginR
|
||||
FormMissing -> redirect LoginR
|
||||
FormSuccess ident ->
|
||||
lift . setCredsRedirect $ Creds "dummy" (CI.original ident) []
|
||||
apDispatch _ _ = notFound
|
||||
apLogin toMaster = do
|
||||
(login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard dummyForm
|
||||
$(widgetFile "widgets/dummy-login-form")
|
||||
@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE RecordWildCards
|
||||
, OverloadedStrings
|
||||
, TemplateHaskell
|
||||
, ViewPatterns
|
||||
, TypeFamilies
|
||||
, FlexibleContexts
|
||||
, FlexibleInstances
|
||||
@ -20,6 +21,9 @@ import Import.NoFoundation
|
||||
import Control.Lens
|
||||
import Network.Connection
|
||||
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Control.Monad.Catch as Exc
|
||||
|
||||
import Utils.Form
|
||||
@ -31,7 +35,10 @@ import qualified Data.Text.Encoding as Text
|
||||
import qualified Yesod.Auth.Message as Msg
|
||||
|
||||
|
||||
data CampusLogin = CampusLogin { campusIdent, campusPassword :: Text }
|
||||
data CampusLogin = CampusLogin
|
||||
{ campusIdent :: CI Text
|
||||
, campusPassword :: Text
|
||||
}
|
||||
|
||||
data CampusMessage = MsgCampusIdentNote
|
||||
| MsgCampusIdent
|
||||
@ -60,7 +67,7 @@ campusForm :: ( RenderMessage site FormMessage
|
||||
, Show (ButtonCssClass site)
|
||||
) => AForm (HandlerT site IO) CampusLogin
|
||||
campusForm = CampusLogin
|
||||
<$> areq textField (fslpI MsgCampusIdent "user.name@campus.lmu.de" & setTooltip MsgCampusIdentNote) Nothing
|
||||
<$> areq ciField (fslpI MsgCampusIdent "user.name@campus.lmu.de" & setTooltip MsgCampusIdentNote) Nothing
|
||||
<*> areq passwordField (fslI MsgCampusPassword) Nothing
|
||||
<* submitButton
|
||||
|
||||
@ -82,7 +89,7 @@ campusLogin conf@LdapConf{..} = AuthPlugin{..}
|
||||
forM_ errs $ addMessage Error . toHtml
|
||||
redirect LoginR
|
||||
FormMissing -> redirect LoginR
|
||||
FormSuccess CampusLogin{..} -> do
|
||||
FormSuccess CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> do
|
||||
ldapResult <- liftIO . Ldap.with ldapHost ldapPort $ \ldap -> do
|
||||
Ldap.bind ldap (Ldap.Dn campusIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword)
|
||||
Ldap.bind ldap ldapDn ldapPassword
|
||||
|
||||
@ -1,60 +0,0 @@
|
||||
{-# LANGUAGE NoImplicitPrelude
|
||||
, QuasiQuotes
|
||||
, TemplateHaskell
|
||||
, ViewPatterns
|
||||
, RecordWildCards
|
||||
, OverloadedStrings
|
||||
, FlexibleContexts
|
||||
, TypeFamilies
|
||||
#-}
|
||||
|
||||
module Auth.PWFile
|
||||
( maintenanceLogin
|
||||
) where
|
||||
|
||||
import Import.NoFoundation
|
||||
import Database.Persist.Sql (IsSqlBackend)
|
||||
|
||||
import qualified Data.Yaml as Yaml
|
||||
|
||||
import qualified Data.Text.Encoding as Text
|
||||
|
||||
import Yesod.Auth.Util.PasswordStore (verifyPassword)
|
||||
|
||||
|
||||
maintenanceLogin :: ( YesodAuth site
|
||||
, YesodPersist site
|
||||
, IsSqlBackend (YesodPersistBackend site)
|
||||
, PersistUniqueWrite (YesodPersistBackend site)
|
||||
) => FilePath -> AuthPlugin site
|
||||
maintenanceLogin fp = AuthPlugin{..}
|
||||
where
|
||||
apName = "PWFile"
|
||||
apLogin = mempty
|
||||
apDispatch "GET" [] = do
|
||||
authData <- lookupBasicAuth
|
||||
pwdata <- liftIO $ Yaml.decodeFileEither fp
|
||||
|
||||
addHeader "WWW-Authenticate" [st|Basic realm="uni2work maintenance auth" charset="UTF-8"|]
|
||||
|
||||
case pwdata of
|
||||
Left err -> $logDebugS "Auth" $ tshow err
|
||||
Right pws -> $logDebugS "Auth" $ tshow (length pws) <> " pw entries"
|
||||
|
||||
case (authData, pwdata) of
|
||||
(Nothing, _) -> do
|
||||
notAuthenticated
|
||||
(Just (usr, (Text.encodeUtf8 -> pw)), Right pwdata')
|
||||
| [ PWEntry{ pwUser = pwUser@(User{..}), pwHash = (Text.encodeUtf8 -> pwHash) } ]
|
||||
<- [ pwe | pwe@PWEntry{..} <- pwdata'
|
||||
, let User{..} = pwUser
|
||||
, userIdent == usr
|
||||
, userPlugin == apName
|
||||
]
|
||||
, verifyPassword pw pwHash
|
||||
-> lift $ do
|
||||
runDB . void $ insertUnique pwUser
|
||||
setCredsRedirect $ Creds apName userIdent []
|
||||
_ -> permissionDenied "Invalid auth"
|
||||
apDispatch _ _ = notFound
|
||||
|
||||
105
src/Auth/PWHash.hs
Normal file
105
src/Auth/PWHash.hs
Normal file
@ -0,0 +1,105 @@
|
||||
{-# LANGUAGE NoImplicitPrelude
|
||||
, QuasiQuotes
|
||||
, TemplateHaskell
|
||||
, ViewPatterns
|
||||
, RecordWildCards
|
||||
, OverloadedStrings
|
||||
, FlexibleContexts
|
||||
, TypeFamilies
|
||||
#-}
|
||||
|
||||
module Auth.PWHash
|
||||
( hashLogin
|
||||
, PWHashMessage(..)
|
||||
) where
|
||||
|
||||
import Import.NoFoundation
|
||||
import Database.Persist.Sql (SqlBackendCanRead)
|
||||
|
||||
import Utils.Form
|
||||
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Yesod.Auth.Util.PasswordStore (verifyPasswordWith)
|
||||
|
||||
import qualified Yesod.Auth.Message as Msg
|
||||
|
||||
|
||||
data HashLogin = HashLogin
|
||||
{ hashIdent :: CI Text
|
||||
, hashPassword :: Text
|
||||
}
|
||||
|
||||
data PWHashMessage = MsgPWHashIdent
|
||||
| MsgPWHashPassword
|
||||
|
||||
|
||||
hashForm :: ( RenderMessage site FormMessage
|
||||
, RenderMessage site PWHashMessage
|
||||
, Button site SubmitButton
|
||||
, Show (ButtonCssClass site)
|
||||
) => AForm (HandlerT site IO) HashLogin
|
||||
hashForm = HashLogin
|
||||
<$> areq ciField (fslpI MsgPWHashIdent "Identifikation") Nothing
|
||||
<*> areq passwordField (fslpI MsgPWHashPassword "Passwort") Nothing
|
||||
<* submitButton
|
||||
|
||||
|
||||
hashLogin :: ( YesodAuth site
|
||||
, YesodPersist site
|
||||
, SqlBackendCanRead (YesodPersistBackend site)
|
||||
, RenderMessage site FormMessage
|
||||
, RenderMessage site PWHashMessage
|
||||
, Button site SubmitButton
|
||||
, Show (ButtonCssClass site)
|
||||
) => PWHashAlgorithm -> AuthPlugin site
|
||||
hashLogin pwHashAlgo = AuthPlugin{..}
|
||||
where
|
||||
apName = "PWHash"
|
||||
apDispatch "POST" [] = do
|
||||
((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard hashForm
|
||||
case loginRes of
|
||||
FormFailure errs -> do
|
||||
forM_ errs $ addMessage Error . toHtml
|
||||
redirect LoginR
|
||||
FormMissing -> redirect LoginR
|
||||
FormSuccess HashLogin{..} -> do
|
||||
user <- lift . runDB . getBy $ UniqueAuthentication hashIdent
|
||||
case user of
|
||||
Just (Entity _ User{ userAuthentication = AuthPWHash{..}, userIdent = CI.original -> userIdent })
|
||||
| verifyPasswordWith pwHashAlgo (2^) (encodeUtf8 hashPassword) (encodeUtf8 authPWHash) -> -- (2^) is magic.
|
||||
lift . setCredsRedirect $ Creds apName userIdent []
|
||||
other -> do
|
||||
$logDebugS "PWHash" $ tshow other
|
||||
loginErrorMessageI LoginR Msg.InvalidLogin
|
||||
-- apDispatch "GET" [] = do
|
||||
-- authData <- lookupBasicAuth
|
||||
-- pwdata <- liftIO $ Yaml.decodeFileEither fp
|
||||
|
||||
-- addHeader "WWW-Authenticate" [st|Basic realm="uni2work maintenance auth" charset="UTF-8"|]
|
||||
|
||||
-- case pwdata of
|
||||
-- Left err -> $logDebugS "Auth" $ tshow err
|
||||
-- Right pws -> $logDebugS "Auth" $ tshow (length pws) <> " pw entries"
|
||||
|
||||
-- case (authData, pwdata) of
|
||||
-- (Nothing, _) -> do
|
||||
-- notAuthenticated
|
||||
-- (Just (usr, (Text.encodeUtf8 -> pw)), Right pwdata')
|
||||
-- | [ PWEntry{ pwUser = pwUser@(User{..}), pwHash = (Text.encodeUtf8 -> pwHash) } ]
|
||||
-- <- [ pwe | pwe@PWEntry{..} <- pwdata'
|
||||
-- , let User{..} = pwUser
|
||||
-- , userIdent == usr
|
||||
-- , userPlugin == apName
|
||||
-- ]
|
||||
-- , verifyPassword pw pwHash
|
||||
-- -> lift $ do
|
||||
-- runDB . void $ insertUnique pwUser
|
||||
-- setCredsRedirect $ Creds apName userIdent []
|
||||
-- _ -> permissionDenied "Invalid auth"
|
||||
apDispatch _ _ = notFound
|
||||
apLogin toMaster = do
|
||||
(login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard hashForm
|
||||
$(widgetFile "widgets/hash-login-form")
|
||||
|
||||
@ -24,7 +24,8 @@ import Text.Jasmine (minifym)
|
||||
import Yesod.Auth.Message
|
||||
import Yesod.Auth.Dummy
|
||||
import Auth.LDAP
|
||||
import Auth.PWFile
|
||||
import Auth.PWHash
|
||||
import Auth.Dummy
|
||||
|
||||
import qualified Network.Wai as W (requestMethod, pathInfo)
|
||||
|
||||
@ -166,6 +167,8 @@ data MenuTypes -- Semantische Rolle:
|
||||
-- Messages
|
||||
mkMessage "UniWorX" "messages/uniworx" "de"
|
||||
mkMessageVariant "UniWorX" "Campus" "messages/campus" "de"
|
||||
mkMessageVariant "UniWorX" "Dummy" "messages/dummy" "de"
|
||||
mkMessageVariant "UniWorX" "PWHash" "messages/pw-hash" "de"
|
||||
|
||||
-- This instance is required to use forms. You can modify renderMessage to
|
||||
-- achieve customized and internationalized form validation messages.
|
||||
@ -1145,18 +1148,14 @@ instance YesodAuth UniWorX where
|
||||
|
||||
authenticate Creds{..} = runDB $ do
|
||||
let
|
||||
(userPlugin, userIdent)
|
||||
| isDummy
|
||||
, [dummyPlugin, dummyIdent] <- Text.splitOn ":" credsIdent
|
||||
= (dummyPlugin, dummyIdent)
|
||||
| otherwise
|
||||
= (credsPlugin, credsIdent)
|
||||
userIdent = CI.mk credsIdent
|
||||
uAuth = UniqueAuthentication userIdent
|
||||
|
||||
isDummy = credsPlugin == "dummy"
|
||||
isPWFile = credsPlugin == "PWFile"
|
||||
uAuth = UniqueAuthentication userPlugin userIdent
|
||||
isPWHash = credsPlugin == "PWHash"
|
||||
|
||||
excHandlers
|
||||
| isDummy || isPWFile
|
||||
| isDummy || isPWHash
|
||||
= [ C.Handler $ \err -> do
|
||||
addMessage Error (toHtml $ tshow (err :: CampusUserException))
|
||||
$logErrorS "LDAP" $ tshow err
|
||||
@ -1182,7 +1181,7 @@ instance YesodAuth UniWorX where
|
||||
|
||||
flip catches excHandlers $ case appLdapConf of
|
||||
Just ldapConf -> fmap (either id id) . runExceptT $ do
|
||||
ldapData <- campusUser ldapConf $ Creds userPlugin userIdent credsExtra
|
||||
ldapData <- campusUser ldapConf $ Creds credsPlugin (CI.original userIdent) credsExtra
|
||||
$logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData
|
||||
|
||||
let
|
||||
@ -1190,6 +1189,10 @@ instance YesodAuth UniWorX where
|
||||
userEmail' = lookup (Attr "mail") ldapData
|
||||
userDisplayName' = lookup (Attr "displayName") ldapData
|
||||
userSurname' = lookup (Attr "sn") ldapData
|
||||
|
||||
userAuthentication
|
||||
| isPWHash = error "PWHash should only work for users that are already known"
|
||||
| otherwise = AuthLDAP
|
||||
|
||||
userEmail <- if
|
||||
| Just [bs] <- userEmail'
|
||||
@ -1262,8 +1265,8 @@ instance YesodAuth UniWorX where
|
||||
|
||||
authPlugins (appSettings -> AppSettings{..}) = catMaybes
|
||||
[ campusLogin <$> appLdapConf
|
||||
, maintenanceLogin <$> appAuthPWFile
|
||||
, authDummy <$ guard appAuthDummyLogin
|
||||
, Just . hashLogin $ pwHashAlgorithm appAuthPWHash
|
||||
, dummyLogin <$ guard appAuthDummyLogin
|
||||
]
|
||||
|
||||
authHttpManager = getHttpManager
|
||||
|
||||
@ -318,8 +318,8 @@ getCourseNewR = do
|
||||
uid <- requireAuthId
|
||||
params <- runInputGetResult $ (,,) --TODO: change to AForm, which is used in Course-Copy-Button
|
||||
<$> iopt termNewField "tid"
|
||||
<*> iopt ciTextField "ssh"
|
||||
<*> iopt ciTextField "csh"
|
||||
<*> iopt ciField "ssh"
|
||||
<*> iopt ciField "csh"
|
||||
let noTemplateAction = courseEditHandler True Nothing
|
||||
case params of
|
||||
FormMissing -> noTemplateAction
|
||||
@ -536,11 +536,11 @@ newCourseForm template = identForm FIDcourse $ \html -> do
|
||||
_allOtherCases -> termsActiveField
|
||||
(result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
|
||||
<$> pure (cfCourseId =<< template)
|
||||
<*> areq (ciField textField) (fslI MsgCourseName) (cfName <$> template)
|
||||
<*> areq ciField (fslI MsgCourseName) (cfName <$> template)
|
||||
<*> aopt htmlField (fslI MsgCourseDescription
|
||||
& setTooltip MsgCourseDescriptionTip) (cfDesc <$> template)
|
||||
<*> aopt urlField (fslI MsgCourseHomepage) (cfLink <$> template)
|
||||
<*> areq (ciField textField) (fslI MsgCourseShorthand
|
||||
<*> areq ciField (fslI MsgCourseShorthand
|
||||
-- & addAttr "disabled" "disabled"
|
||||
& setTooltip MsgCourseShorthandUnique)
|
||||
(cfShort <$> template)
|
||||
|
||||
@ -108,7 +108,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
|
||||
mr <- getMsgRenderer
|
||||
ctime <- liftIO $ getCurrentTime
|
||||
(result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
|
||||
<$> areq (ciField textField) (fslI MsgSheetName) (sfName <$> template)
|
||||
<$> areq ciField (fslI MsgSheetName) (sfName <$> template)
|
||||
<*> aopt htmlField (fslI MsgSheetDescription) (sfDescription <$> template)
|
||||
<*> sheetTypeAFormReq (fslI MsgSheetType) (sfType <$> template)
|
||||
<*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template)
|
||||
|
||||
@ -71,7 +71,7 @@ makeSubmissionForm msmid uploadMode grouping buddies = identForm FIDsubmission $
|
||||
(Upload unpackZips) -> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
|
||||
flip (renderAForm FormStandard) html $ (,)
|
||||
<$> fileUpload
|
||||
<*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies (ciField textField) (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) buddy
|
||||
<*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies ciField (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) buddy
|
||||
| g <- [1..(max groupNr $ length buddies)] -- groupNr might have decreased meanwhile
|
||||
| buddy <- map (Just . Just) buddies ++ repeat Nothing -- show current buddies
|
||||
])
|
||||
|
||||
@ -14,6 +14,8 @@ import Handler.Utils
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
|
||||
@ -116,7 +118,7 @@ postAdminHijackUserR cID = do
|
||||
permissionDenied "Cannot escalate admin status to additional schools"
|
||||
|
||||
get404 uid
|
||||
setCredsRedirect $ Creds "dummy" (userPlugin <> ":" <> userIdent) []
|
||||
setCredsRedirect $ Creds "dummy" (CI.original userIdent) []
|
||||
| otherwise -> error "This should be impossible by definition of `hijackUserForm`"
|
||||
FormFailure errs -> toTypedContent <$> mapM_ (addMessage Error . toHtml) errs
|
||||
FormMissing -> return $ toTypedContent ()
|
||||
|
||||
@ -183,11 +183,7 @@ buttonForm csrf = do
|
||||
-- Fields --
|
||||
------------
|
||||
|
||||
ciField :: (Functor m, CI.FoldCase a) => Field m a -> Field m (CI a)
|
||||
ciField = convertField CI.mk CI.original
|
||||
|
||||
ciTextField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m (CI Text)
|
||||
ciTextField = ciField textField
|
||||
-- ciField moved to Utils.Form
|
||||
|
||||
natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i
|
||||
natFieldI msg = checkBool (>= 0) msg intField
|
||||
|
||||
@ -180,6 +180,15 @@ customMigrations = Map.fromListWith (>>)
|
||||
ALTER TABLE "sheet" ADD COLUMN "upload_mode" json DEFAULT '{ "tag": "Upload", "unpackZips": true }';
|
||||
|]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|3.2.0|] [version|4.0.0|]
|
||||
, whenM (tableExists "user") $ do
|
||||
-- <> is standard sql for /=
|
||||
[executeQQ|
|
||||
DELETE FROM "user" WHERE "plugin" <> 'LDAP';
|
||||
ALTER TABLE "user" DROP COLUMN "plugin";
|
||||
ALTER TABLE "user" ADD COLUMN "authentication" json DEFAULT '"ldap"';
|
||||
|]
|
||||
)
|
||||
]
|
||||
|
||||
|
||||
|
||||
@ -46,12 +46,14 @@ import Data.CaseInsensitive.Instances ()
|
||||
|
||||
import Yesod.Core.Dispatch (PathPiece(..))
|
||||
import Data.Aeson (FromJSON(..), ToJSON(..), withText, Value(..))
|
||||
import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..))
|
||||
import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..))
|
||||
|
||||
import GHC.Generics (Generic)
|
||||
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
|
||||
import Data.Typeable (Typeable)
|
||||
|
||||
import qualified Yesod.Auth.Util.PasswordStore as PWStore
|
||||
|
||||
|
||||
instance PathPiece UUID where
|
||||
fromPathPiece = Data.UUID.Types.fromString . unpack
|
||||
@ -390,7 +392,7 @@ instance PathPiece obj => PathPiece (ZIPArchiveName obj) where
|
||||
toPathPiece = (<> ".zip") . toPathPiece . unZIPArchiveName
|
||||
|
||||
newtype DateTimeFormat = DateTimeFormat { unDateTimeFormat :: String }
|
||||
deriving (Eq, Ord, Read, Show, ToJSON, FromJSON, PersistField, PersistFieldSql)
|
||||
deriving (Eq, Ord, Read, Show, ToJSON, FromJSON, PersistField, PersistFieldSql, IsString)
|
||||
|
||||
data SelDateTimeFormat = SelFormatDateTime | SelFormatDate | SelFormatTime
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded)
|
||||
@ -409,12 +411,25 @@ instance Universe CorrectorState where universe = universeDef
|
||||
instance Finite CorrectorState
|
||||
|
||||
instance PathPiece CorrectorState where
|
||||
toPathPiece = $(nullaryToPathPiece ''CorrectorState [Text.intercalate "-" . map Text.toLower . unsafeTail . splitCamel])
|
||||
toPathPiece = $(nullaryToPathPiece ''CorrectorState [Text.intercalate "-" . map toLower . unsafeTail . splitCamel])
|
||||
fromPathPiece = finiteFromPathPiece
|
||||
|
||||
derivePersistField "CorrectorState"
|
||||
|
||||
|
||||
data AuthenticationMode = AuthLDAP
|
||||
| AuthPWHash { authPWHash :: Text }
|
||||
deriving (Eq, Ord, Read, Show)
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
|
||||
, fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
|
||||
, sumEncoding = UntaggedValue
|
||||
} ''AuthenticationMode
|
||||
|
||||
derivePersistFieldJSON ''AuthenticationMode
|
||||
|
||||
|
||||
-- Type synonyms
|
||||
|
||||
type SchoolName = CI Text
|
||||
@ -423,3 +438,5 @@ type CourseName = CI Text
|
||||
type CourseShorthand = CI Text
|
||||
type SheetName = CI Text
|
||||
type UserEmail = CI Text
|
||||
|
||||
type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString
|
||||
|
||||
@ -16,6 +16,7 @@ import ClassyPrelude.Yesod
|
||||
import qualified Control.Exception as Exception
|
||||
import Data.Aeson (Result (..), fromJSON, withObject,
|
||||
(.!=), (.:?))
|
||||
import qualified Data.Aeson.Types as Aeson
|
||||
import Data.Aeson.TH
|
||||
import Data.FileEmbed (embedFile)
|
||||
import Data.Yaml (decodeEither')
|
||||
@ -26,6 +27,7 @@ import Yesod.Default.Config2 (applyEnvValue, configSettingsYml)
|
||||
import Yesod.Default.Util (WidgetFileSettings,
|
||||
widgetFileNoReload,
|
||||
widgetFileReload)
|
||||
import qualified Yesod.Auth.Util.PasswordStore as PWStore
|
||||
|
||||
import qualified Data.Text.Encoding as Text
|
||||
|
||||
@ -74,32 +76,36 @@ data AppSettings = AppSettings
|
||||
-- ^ Indicate if auth dummy login should be enabled.
|
||||
, appAllowDeprecated :: Bool
|
||||
-- ^ Indicate if deprecated routes are accessible for everyone
|
||||
, appAuthPWFile :: Maybe FilePath
|
||||
-- ^ If set authenticate against a local password file
|
||||
, appMinimumLogLevel :: LogLevel
|
||||
|
||||
, appUserDefaults :: UserDefaultConf
|
||||
, appAuthPWHash :: PWHashConf
|
||||
|
||||
, appCryptoIDKeyFile :: FilePath
|
||||
}
|
||||
|
||||
|
||||
data UserDefaultConf = UserDefaultConf
|
||||
{ userDefaultTheme :: Theme
|
||||
, userDefaultMaxFavourites :: Int
|
||||
, userDefaultDateTimeFormat, userDefaultDateFormat, userDefaultTimeFormat :: DateTimeFormat
|
||||
, userDefaultDownloadFiles :: Bool
|
||||
}
|
||||
|
||||
data PWHashConf = PWHashConf
|
||||
{ pwHashAlgorithm :: PWHashAlgorithm
|
||||
, pwHashStrength :: Int
|
||||
}
|
||||
|
||||
instance FromJSON UserDefaultConf where
|
||||
parseJSON = withObject "UserDefaultConf" $ \o -> do
|
||||
userDefaultTheme <- o .: "theme"
|
||||
userDefaultMaxFavourites <- o .: "favourites"
|
||||
userDefaultDateTimeFormat <- o .: "date-time-format"
|
||||
userDefaultDateFormat <- o .: "date-format"
|
||||
userDefaultTimeFormat <- o .: "time-format"
|
||||
userDefaultDownloadFiles <- o .: "download-files"
|
||||
instance FromJSON PWHashConf where
|
||||
parseJSON = withObject "PWHashConf" $ \o -> do
|
||||
pwHashAlgorithm' <- (o .: "algorithm" :: Aeson.Parser Text)
|
||||
pwHashAlgorithm <- if
|
||||
| pwHashAlgorithm' == "pbkdf1" -> return PWStore.pbkdf1
|
||||
| pwHashAlgorithm' == "pbkdf2" -> return PWStore.pbkdf2
|
||||
| otherwise -> fail "Unsupported hash algorithm"
|
||||
pwHashStrength <- o .: "strength"
|
||||
|
||||
return UserDefaultConf{..}
|
||||
return PWHashConf{..}
|
||||
|
||||
data LdapConf = LdapConf
|
||||
{ ldapHost :: Ldap.Host, ldapPort :: Ldap.PortNumber
|
||||
@ -108,8 +114,11 @@ data LdapConf = LdapConf
|
||||
, ldapScope :: Ldap.Scope
|
||||
, ldapTimeout :: Int32
|
||||
}
|
||||
|
||||
|
||||
deriveFromJSON defaultOptions ''Ldap.Scope
|
||||
deriveFromJSON defaultOptions
|
||||
{ fieldLabelModifier = intercalate "-" . map toLower . drop 2 . splitCamel
|
||||
} ''UserDefaultConf
|
||||
|
||||
instance FromJSON LdapConf where
|
||||
parseJSON = withObject "LdapConf" $ \o -> do
|
||||
@ -164,9 +173,9 @@ instance FromJSON AppSettings where
|
||||
appSkipCombining <- o .:? "skip-combining" .!= defaultDev
|
||||
appAuthDummyLogin <- o .:? "auth-dummy-login" .!= defaultDev
|
||||
appAllowDeprecated <- o .:? "allow-deprecated" .!= defaultDev
|
||||
appAuthPWFile <- assertM (not . null) <$> o .:? "auth-pwfile"
|
||||
|
||||
appUserDefaults <- o .: "user-defaults"
|
||||
appAuthPWHash <- o .: "auth-pw-hash"
|
||||
|
||||
appCryptoIDKeyFile <- o .: "cryptoid-keyfile"
|
||||
|
||||
|
||||
@ -20,6 +20,9 @@ import qualified Text.Blaze.Internal as Blaze (null)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Char as Char
|
||||
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Web.PathPieces
|
||||
|
||||
-------------------
|
||||
@ -118,6 +121,20 @@ setNameClass fs gName gClass = fs { fsName= Just gName, fsAttrs=("class",gClass)
|
||||
setTooltip :: RenderMessage site msg => msg -> FieldSettings site -> FieldSettings site
|
||||
setTooltip msg fs = fs { fsTooltip = Just $ SomeMessage msg }
|
||||
|
||||
addDatalist :: (PathPiece (Element vals), MonoFoldable vals, Monad m) => Field m a -> WidgetT (HandlerSite m) IO vals -> Field m a
|
||||
addDatalist field mValues = field
|
||||
{ fieldView = \fId fName fAttrs fRes fReq -> do
|
||||
listId <- newIdent
|
||||
values <- map toPathPiece . otoList <$> mValues
|
||||
fieldView field fId fName (("list", listId) : fAttrs) fRes fReq
|
||||
[whamlet|
|
||||
$newline never
|
||||
<datalist ##{listId}>
|
||||
$forall value <- values
|
||||
<option value=#{value}>
|
||||
|]
|
||||
}
|
||||
|
||||
------------------------------------------------
|
||||
-- Unique Form Identifiers to avoid accidents --
|
||||
------------------------------------------------
|
||||
@ -188,3 +205,14 @@ combinedButtonField btns = traverse b2f btns
|
||||
|
||||
submitButton :: (Button site SubmitButton, Show (ButtonCssClass site)) => AForm (HandlerT site IO) ()
|
||||
submitButton = void $ combinedButtonField [BtnSubmit]
|
||||
|
||||
-------------------
|
||||
-- Custom Fields --
|
||||
-------------------
|
||||
|
||||
ciField :: ( Textual t
|
||||
, CI.FoldCase t
|
||||
, Monad m
|
||||
, RenderMessage (HandlerSite m) FormMessage
|
||||
) => Field m (CI t)
|
||||
ciField = convertField (CI.mk . fromList . unpack) (pack . toList . CI.original) textField
|
||||
|
||||
@ -35,14 +35,14 @@ nullaryToPathPiece nullaryType manglers = do
|
||||
where
|
||||
mangle = appEndo (foldMap Endo manglers) . Text.pack
|
||||
|
||||
splitCamel :: Text -> [Text]
|
||||
splitCamel = map Text.pack . reverse . helper (error "hasChange undefined at start of string") [] "" . Text.unpack
|
||||
splitCamel :: Textual t => t -> [t]
|
||||
splitCamel = map fromList . reverse . helper (error "hasChange undefined at start of string") [] "" . otoList
|
||||
where
|
||||
helper _hadChange items thisWord [] = reverse thisWord : items
|
||||
helper _hadChange items [] (c:cs) = helper True items [c] cs
|
||||
helper hadChange items ws@(w:ws') (c:cs)
|
||||
| sameCategory w c
|
||||
, null ws' = helper False items (c:ws) cs
|
||||
, null ws' = helper (Char.isLower w) items (c:ws) cs
|
||||
| sameCategory w c = helper hadChange items (c:ws) cs
|
||||
| null ws' = helper True items (c:ws) cs
|
||||
| not hadChange = helper True (reverse ws':items) [c,w] cs
|
||||
|
||||
@ -3,6 +3,11 @@ $forall AuthPlugin{..} <- plugins
|
||||
<section>
|
||||
<h2>_{MsgLDAPLoginTitle}
|
||||
^{apLogin toParent}
|
||||
$elseif apName == "PWHash"
|
||||
<section>
|
||||
<h2>_{MsgPWHashLoginTitle}
|
||||
<p>_{MsgPWHashLoginNote}
|
||||
^{apLogin toParent}
|
||||
$elseif apName == "dummy"
|
||||
<section>
|
||||
<h2>_{MsgDummyLoginTitle}
|
||||
|
||||
@ -10,8 +10,6 @@
|
||||
<dd .deflist__dd> #{display userEmail}
|
||||
<dt .deflist__dt> _{MsgIdent}
|
||||
<dd .deflist__dd> #{display userIdent}
|
||||
<dt .deflist__dt> _{MsgPlugin}
|
||||
<dd .deflist__dd> #{display userPlugin}
|
||||
$if not $ null admin_rights
|
||||
<dt .deflist__dt> Administrator
|
||||
<dd .deflist__dd>
|
||||
|
||||
2
templates/widgets/dummy-login-form.hamlet
Normal file
2
templates/widgets/dummy-login-form.hamlet
Normal file
@ -0,0 +1,2 @@
|
||||
<form method=POST action=@{toMaster $ PluginR "dummy" []} enctype=#{loginEnctype}>
|
||||
^{login}
|
||||
2
templates/widgets/hash-login-form.hamlet
Normal file
2
templates/widgets/hash-login-form.hamlet
Normal file
@ -0,0 +1,2 @@
|
||||
<form method=POST action=@{toMaster $ PluginR "PWHash" []} enctype=#{loginEnctype}>
|
||||
^{login}
|
||||
Loading…
Reference in New Issue
Block a user