Overhaul authentication

Fixes #186

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"

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"

messages/pw-hash/de.msg

@@ -0,0 +1,2 @@
+PWHashIdent: Identifikation
+PWHashPassword: Passwort

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.
 
@@ -285,6 +285,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

models

@@ -1,6 +1,6 @@
 User json
-    plugin         Text
+    ident          (CI Text)
-    ident          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

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 -}
+addPWEntry :: User
-           -> User
            -> Text {-^ Password -}
            -> IO ()
-addPWEntry pwFile User{..} (Text.encodeUtf8 -> pw) = do
+addPWEntry User{..} (Text.encodeUtf8 -> pw) = db $ do
-  (Text.decodeUtf8 -> pwHash) <- makePassword pw 14
+  PWHashConf{..} <- getsYesod $ appAuthPWHash . appSettings
-  let pwEntry = PWEntry{ pwUser = User{ userPlugin = "PWFile", .. }, .. }
+  (AuthPWHash . Text.decodeUtf8 -> userAuthentication) <- liftIO $ makePasswordWith pwHashAlgorithm pw pwHashStrength
-      newUser = userIdent
+  void $ insert User{..}
-  c <- either (const []) id <$> Yaml.decodeFileEither pwFile
-  Yaml.encodeFile pwFile $ pwEntry : [ c' | c'@(PWEntry{pwUser=User{..}}) <- c, userIdent /= newUser ]

src/Auth/Dummy.hs

@@ -16,6 +16,9 @@ import Database.Persist.Sql (SqlBackendCanRead)
 
 import Utils.Form
   
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+
 
 data DummyMessage = MsgDummyIdent
 
@@ -26,12 +29,12 @@ dummyForm :: ( RenderMessage site FormMessage
              , SqlBackendCanRead (YesodPersistBackend site)
              , Button site SubmitButton
              , Show (ButtonCssClass site)
-             ) => AForm (HandlerT site IO) Text
+             ) => AForm (HandlerT site IO) (CI Text)
-dummyForm = areq userField (fslpI MsgDummyIdent "plugin:ident") Nothing
+dummyForm = areq (selectField userList) (fslI MsgDummyIdent) Nothing
          <* submitButton
   where
-    userField = textField `addDatalist` liftHandlerT (runDB userList)
+    userList = fmap mkOptionList . runDB $ map toOption <$> selectList [] [Asc UserIdent]
-    userList = map (\(Entity _ User{..}) -> userPlugin <> ":" <> userIdent) <$> selectList [] [Asc UserPlugin, Asc UserIdent]
+    toOption (Entity _ User{..}) = Option (CI.original userIdent) userIdent (CI.original userIdent)
 
 dummyLogin :: ( YesodAuth site
               , YesodPersist site
@@ -53,7 +56,7 @@ dummyLogin = AuthPlugin{..}
           redirect LoginR
         FormMissing -> redirect LoginR
         FormSuccess ident ->
-          lift . setCredsRedirect $ Creds "dummy" ident []
+          lift . setCredsRedirect $ Creds "dummy" (CI.original ident) []
     apDispatch _ _ = notFound
     apLogin toMaster = do
       (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard dummyForm

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

src/Auth/PWFile.hs

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

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")
+

src/Foundation.hs

@@ -24,7 +24,7 @@ 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)
@@ -168,6 +168,7 @@ data MenuTypes                                 -- Semantische Rolle:
 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.
@@ -1141,18 +1142,14 @@ instance YesodAuth UniWorX where
 
     authenticate Creds{..} = runDB $ do
       let
-        (userPlugin, userIdent)
+        userIdent = CI.mk credsIdent
-          | isDummy
+        uAuth = UniqueAuthentication userIdent
-          , [dummyPlugin, dummyIdent] <- Text.splitOn ":" credsIdent
+
-          = (dummyPlugin, dummyIdent)
-          | otherwise
-          = (credsPlugin, credsIdent)
         isDummy = credsPlugin == "dummy"
-        isPWFile = credsPlugin == "PWFile"
+        isPWHash = credsPlugin == "PWHash"
-        uAuth = UniqueAuthentication userPlugin userIdent
 
         excHandlers
-          | isDummy || isPWFile
+          | isDummy || isPWHash
           = [ C.Handler $ \err -> do
                 addMessage "error" (toHtml $ tshow (err :: CampusUserException))
                 $logErrorS "LDAP" $ tshow err
@@ -1178,7 +1175,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
@@ -1187,6 +1184,10 @@ instance YesodAuth UniWorX where
             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'
             , Right userEmail <- Text.decodeUtf8' bs
@@ -1258,7 +1259,7 @@ instance YesodAuth UniWorX where
 
     authPlugins (appSettings -> AppSettings{..}) = catMaybes
       [ campusLogin <$> appLdapConf
-      , maintenanceLogin <$> appAuthPWFile
+      , Just . hashLogin $ pwHashAlgorithm appAuthPWHash
       , dummyLogin <$ guard appAuthDummyLogin
       ]
 

src/Handler/Course.hs

@@ -317,9 +317,9 @@ getCourseNewR :: Handler Html
 getCourseNewR = do
   uid <- requireAuthId
   params <- runInputGetResult $ (,,)
-            <$> ireq ciTextField "csh"
+            <$> ireq ciField   "csh"
-            <*> iopt   textField "tid"
+            <*> iopt textField "tid"
-            <*> iopt ciTextField "ssh"
+            <*> iopt ciField   "ssh"
   let noTemplateAction = courseEditHandler True Nothing
   case params of
     FormMissing      -> noTemplateAction
@@ -530,11 +530,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)

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)

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

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 ()

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 moved to Utils.Form
-ciField = convertField CI.mk CI.original
-
-ciTextField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m (CI Text)
-ciTextField = ciField textField
 
 natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i
 natFieldI msg = checkBool (>= 0) msg intField

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"';
+        |]
+    )
   ]
 
 

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
@@ -388,7 +390,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)
@@ -405,12 +407,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
@@ -419,3 +434,5 @@ type CourseName      = CI Text
 type CourseShorthand = CI Text
 type SheetName       = CI Text
 type UserEmail       = CI Text
+
+type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString

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,11 +76,10 @@ 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
     }
@@ -90,16 +91,21 @@ data UserDefaultConf = UserDefaultConf
   , userDefaultDownloadFiles :: Bool
   }
  
-instance FromJSON UserDefaultConf where
+data PWHashConf = PWHashConf
-  parseJSON = withObject "UserDefaultConf" $ \o -> do
+  { pwHashAlgorithm :: PWHashAlgorithm
-    userDefaultTheme          <- o .: "theme"
+  , pwHashStrength :: Int
-    userDefaultMaxFavourites  <- o .: "favourites"
+  }
-    userDefaultDateTimeFormat <- o .: "date-time-format"
-    userDefaultDateFormat     <- o .: "date-format"
-    userDefaultTimeFormat     <- o .: "time-format"
-    userDefaultDownloadFiles  <- o .: "download-files"
 
-    return UserDefaultConf{..}
+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 PWHashConf{..}
 
 data LdapConf = LdapConf
   { ldapHost :: Ldap.Host, ldapPort :: Ldap.PortNumber
@@ -110,6 +116,9 @@ data LdapConf = LdapConf
   }
  
 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"
 

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

src/Utils/PathPiece.hs

@@ -35,14 +35,14 @@ nullaryToPathPiece nullaryType manglers = do
   where
     mangle = appEndo (foldMap Endo manglers) . Text.pack
   
-splitCamel :: Text -> [Text]
+splitCamel :: Textual t => t -> [t]
-splitCamel = map Text.pack . reverse . helper (error "hasChange undefined at start of string") [] "" . Text.unpack
+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

templates/login.hamlet

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

templates/profile.hamlet

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

templates/widgets/hash-login-form.hamlet

@@ -0,0 +1,2 @@
+<form method=POST action=@{toMaster $ PluginR "PWHash" []} enctype=#{loginEnctype}>
+  ^{login}