diff --git a/config/settings.yml b/config/settings.yml index 72965a276..75d5af052 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -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" diff --git a/db.hs b/db.hs index 0fe4b8812..3bb77bcf5 100755 --- a/db.hs +++ b/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" diff --git a/messages/dummy/de.msg b/messages/dummy/de.msg new file mode 100644 index 000000000..f3ca7cae1 --- /dev/null +++ b/messages/dummy/de.msg @@ -0,0 +1 @@ +DummyIdent: Nutzer-Kennung \ No newline at end of file diff --git a/messages/pw-hash/de.msg b/messages/pw-hash/de.msg new file mode 100644 index 000000000..9fb1eb5e4 --- /dev/null +++ b/messages/pw-hash/de.msg @@ -0,0 +1,2 @@ +PWHashIdent: Identifikation +PWHashPassword: Passwort \ No newline at end of file diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 563d3227c..c1b8fcca7 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -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 diff --git a/models b/models index a83eb4e9c..594b69fad 100644 --- a/models +++ b/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 diff --git a/src/Application.hs b/src/Application.hs index c5b69f55f..9c4cb5a54 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -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{..} diff --git a/src/Auth/Dummy.hs b/src/Auth/Dummy.hs new file mode 100644 index 000000000..809db8647 --- /dev/null +++ b/src/Auth/Dummy.hs @@ -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") diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index bc7a639b7..32c185519 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -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 diff --git a/src/Auth/PWFile.hs b/src/Auth/PWFile.hs deleted file mode 100644 index 541be7718..000000000 --- a/src/Auth/PWFile.hs +++ /dev/null @@ -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 - diff --git a/src/Auth/PWHash.hs b/src/Auth/PWHash.hs new file mode 100644 index 000000000..ba7198710 --- /dev/null +++ b/src/Auth/PWHash.hs @@ -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") + diff --git a/src/Foundation.hs b/src/Foundation.hs index bb7595fc7..105c859ab 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -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 diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index f5af4b949..47240a3ed 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -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) diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index c9d244ae0..67d119c10 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -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) diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 39abc8e00..b64be4126 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -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 ]) diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 0cd7de45c..8208d1a1f 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -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 () diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 6cfbe37bf..6236c1194 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -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 diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 5b45329f9..54ec40156 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -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"'; + |] + ) ] diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 17d4e091d..4f406a148 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -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 diff --git a/src/Settings.hs b/src/Settings.hs index 4869e236e..4649c76f4 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -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" diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 208d42caf..939169e9b 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -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 + + $forall value <- values +