diff --git a/config/settings.yml b/config/settings.yml index d369568f1..e45f7995b 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -35,10 +35,13 @@ database: poolsize: "_env:PGPOOLSIZE:10" ldap: - uri: "_env:LDAPURI:ldap://localhost:389" - dn: "_env:LDAPDN:uniworx" - password: "_env:LDAPPW:" - basename: "_env:LDAPBN:" + host: "_env:LDAPHOST:" + tls: "_env:LDAPTLS:" + port: "_env:LDAPPORT:389" + user: "_env:LDAPUSER:" + pass: "_env:LDAPPASS:" + baseDN: "_env:LDAPBASE:" + scope: "_env:LDAPSCOPE:WholeSubtree" default-favourites: 12 default-theme: Default diff --git a/messages/campus/de.msg b/messages/campus/de.msg new file mode 100644 index 000000000..7e8a58a7f --- /dev/null +++ b/messages/campus/de.msg @@ -0,0 +1,4 @@ +CampusNote: Campus-Kennung bitte inkl. Domain-Teil (@campus.lmu.de) angeben. +CampusIdent: Campus-Kennung +CampusPassword: Passwort +CampusSubmit: Abschicken \ No newline at end of file diff --git a/messages/de.msg b/messages/uniworx/de.msg similarity index 100% rename from messages/de.msg rename to messages/uniworx/de.msg diff --git a/package.yaml b/package.yaml index f6aba2b60..47b09239e 100644 --- a/package.yaml +++ b/package.yaml @@ -74,8 +74,6 @@ dependencies: - generic-deriving - blaze-html - conduit-resumablesink >=0.2 -- yesod-auth-ldap -- LDAP - parsec - uuid - exceptions @@ -88,6 +86,7 @@ dependencies: - th-lift-instances - gitrev - Glob +- ldap-client # The library contains all of our application code. The executable # defined below is just a thin wrapper. diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs new file mode 100644 index 000000000..2152d55bf --- /dev/null +++ b/src/Auth/LDAP.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE RecordWildCards + , OverloadedStrings + , TemplateHaskell + , TypeFamilies + , FlexibleContexts + , FlexibleInstances + , NoImplicitPrelude + #-} + +module Auth.LDAP + ( campusLogin + , CampusMessage(..) + ) where + +import Import.NoFoundation +import Control.Lens + +import Utils.Form + +data CampusLogin = CampusLogin { campusIdent, campusPassword :: Text } + +data CampusMessage = MsgCampusNote + | MsgCampusIdent + | MsgCampusPassword + | MsgCampusSubmit + + +campusForm :: ( RenderMessage site FormMessage + , RenderMessage site CampusMessage + , Button site SubmitButton + , Show (ButtonCssClass site) + ) => AForm (HandlerT site IO) CampusLogin +campusForm = CampusLogin + <$> areq textField (fslI MsgCampusIdent) Nothing + <*> areq passwordField (fslI MsgCampusPassword) Nothing + <* submitButton + +campusLogin :: ( YesodAuth site + , RenderMessage site FormMessage + , RenderMessage site CampusMessage + , Button site SubmitButton + , Show (ButtonCssClass site) + ) => LdapConf -> AuthPlugin site +campusLogin conf = AuthPlugin{..} + where + apName = "LDAP" + apDispatch _ _ = notFound + apLogin toMaster = do + (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard campusForm + $(widgetFile "widgets/campus-login-form") + +-- ldapConfig :: UniWorX -> LDAPConfig +-- ldapConfig _app@(appSettings -> settings) = LDAPConfig +-- { usernameFilter = \u -> principalName <> "=" <> u +-- , identifierModifier +-- , ldapUri = appLDAPURI settings +-- , initDN = appLDAPDN settings +-- , initPass = appLDAPPw settings +-- , baseDN = appLDAPBaseName settings +-- , ldapScope = LdapScopeSubtree +-- } +-- where +-- principalName :: IsString a => a +-- principalName = "userPrincipalName" +-- identifierModifier _ entry = case lookup principalName $ leattrs entry of +-- Just [n] -> Text.pack n +-- _ -> error "Could not determine user principal name" diff --git a/src/Auth/PWFile.hs b/src/Auth/PWFile.hs new file mode 100644 index 000000000..541be7718 --- /dev/null +++ b/src/Auth/PWFile.hs @@ -0,0 +1,60 @@ +{-# 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/Foundation.hs b/src/Foundation.hs index b8f8fe169..1536188d9 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -23,13 +23,11 @@ import Text.Jasmine (minifym) -- Used only when in "auth-dummy-login" setting is enabled. import Yesod.Auth.Message import Yesod.Auth.Dummy -import Yesod.Auth.LDAP +import Auth.LDAP +import Auth.PWFile import qualified Network.Wai as W (requestMethod, pathInfo) -import LDAP.Data (LDAPScope(..)) -import LDAP.Search (LDAPEntry(..)) - import Yesod.Default.Util (addStaticContentExternal) import Yesod.Core.Types (Logger) import qualified Yesod.Core.Unsafe as Unsafe @@ -43,8 +41,6 @@ import Data.ByteArray (convert) import Crypto.Hash (Digest, SHAKE256) import Crypto.Hash.Conduit (sinkHash) -import Yesod.Auth.Util.PasswordStore - import qualified Data.ByteString.Base64.URL as Base64 (encode) import Data.ByteString (ByteString) @@ -81,6 +77,7 @@ import Handler.Utils.Templates import Handler.Utils.StudyFeatures import Control.Lens import Utils +import Utils.Form import Utils.Lens import Data.Aeson @@ -164,7 +161,8 @@ data MenuTypes -- Semantische Rolle: | PageActionSecondary { menuItem :: MenuItem } -- Seitenspezifische Aktion, selten -- Messages -mkMessage "UniWorX" "messages" "de" +mkMessage "UniWorX" "messages/uniworx" "de" +mkMessageVariant "UniWorX" "Campus" "messages/campus" "de" -- This instance is required to use forms. You can modify renderMessage to -- achieve customized and internationalized form validation messages. @@ -200,6 +198,16 @@ instance RenderMessage UniWorX SheetFileType where instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route) + +data instance ButtonCssClass UniWorX = BCDefault | BCPrimary | BCSuccess | BCInfo | BCWarning | BCDanger | BCLink + deriving (Enum, Eq, Ord, Bounded, Read, Show) + +instance Button UniWorX SubmitButton where + label BtnSubmit = [whamlet|_{MsgBtnSubmit}|] + + cssClass BtnSubmit = BCPrimary + + getTimeLocale' :: [Lang] -> TimeLocale getTimeLocale' = $(timeLocaleMap [("de", "de_DE.utf8")]) @@ -1130,72 +1138,14 @@ instance YesodAuth UniWorX where where insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ()) - -- You can add other plugins like Google Email, email or OAuth here - authPlugins app = [genericAuthLDAP $ ldapConfig app] ++ extraAuthPlugins - -- Enable authDummy login if enabled. - where extraAuthPlugins = [authDummy | appAuthDummyLogin $ appSettings app] - ++ [authPWFile fp | fp <- maybeToList . appAuthPWFile $ appSettings app] + authPlugins (appSettings -> AppSettings{..}) = catMaybes + [ campusLogin <$> appLdapConf + , maintenanceLogin <$> appAuthPWFile + , authDummy <$ guard appAuthDummyLogin + ] + authHttpManager = getHttpManager -authPWFile :: FilePath -> AuthPlugin UniWorX -authPWFile 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 - - -ldapConfig :: UniWorX -> LDAPConfig -ldapConfig _app@(appSettings -> settings) = LDAPConfig - { usernameFilter = \u -> principalName <> "=" <> u - , identifierModifier - , ldapUri = appLDAPURI settings - , initDN = appLDAPDN settings - , initPass = appLDAPPw settings - , baseDN = appLDAPBaseName settings - , ldapScope = LdapScopeSubtree - } - where - principalName :: IsString a => a - principalName = "userPrincipalName" - identifierModifier _ entry = case lookup principalName $ leattrs entry of - Just [n] -> Text.pack n - _ -> error "Could not determine user principal name" - --- | Access function to determine if a user is logged in. -isAuthenticated :: Handler AuthResult -isAuthenticated = do - muid <- maybeAuthId - return $ case muid of - Nothing -> Unauthorized "You must login to access this page" - Just _ -> Authorized - - instance YesodAuthPersist UniWorX -- Useful when writing code that is re-usable outside of the Handler context. diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index d3e5d2353..d0682f855 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -33,7 +33,7 @@ instance PathPiece CreateButton where -- for displaying the button only, not toPathPiece = showToPathPiece fromPathPiece = readFromPathPiece -instance Button CreateButton where +instance Button UniWorX CreateButton where label CreateMath = [whamlet|Mathematik|] label CreateInf = "Informatik" diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 280f5dfa6..7600f1d8e 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -11,7 +11,12 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE LambdaCase #-} -module Handler.Utils.Form where +module Handler.Utils.Form + ( module Handler.Utils.Form + , module Utils.Form + ) where + +import Utils.Form import Handler.Utils.Form.Types import Handler.Utils.Templates @@ -34,8 +39,6 @@ import qualified Data.Text as T import Yesod.Form.Functions (parseHelper) import Yesod.Form.Bootstrap3 -import qualified Text.Blaze.Internal as Blaze (null) - import Web.PathPieces (showToPathPiece, readFromPathPiece) import Handler.Utils.Zip @@ -56,54 +59,10 @@ import Data.Scientific (Scientific) import Data.Ratio import Text.Read (readMaybe) ------------------------------------------------- --- Unique Form Identifiers to avoid accidents -- ------------------------------------------------- - -data FormIdentifier = FIDcourse | FIDsheet | FIDsubmission | FIDsettings | FIDcorrectors | FIDcorrectorTable | FIDcorrection | FIDcorrectionsUpload | FIDcorrectionUpload - deriving (Enum, Eq, Ord, Bounded, Read, Show) - - -identForm :: FormIdentifier -> Form a -> Form a -identForm fid = identifyForm (T.pack $ show fid) - -{- Hinweise zur Erinnerung: - - identForm primär, wenn es mehr als ein Formular pro Handler gibt - - nur einmal pro makeForm reicht --} - -------------------- --- Form Renderer -- -------------------- - --- | Use this type to pass information to the form template -data FormLayout = FormStandard - -renderAForm :: Monad m => FormLayout -> FormRender m a -renderAForm formLayout aform fragment = do - (res, (($ []) -> views)) <- aFormToForm aform - let widget = $(widgetFile "widgets/form") - return (res, widget) - ---------------------------- -- Buttons (new version ) -- ---------------------------- -data ButtonCssClass = BCDefault | BCPrimary | BCSuccess | BCInfo | BCWarning | BCDanger | BCLink - deriving (Enum, Eq, Ord, Bounded, Read, Show) - -bcc2txt :: ButtonCssClass -> Text -- a Hack; maybe define Read/Show manually -bcc2txt bcc = T.pack $ "btn-" ++ (Char.toLower <$> (drop 2 $ show bcc)) - -class (Enum a, Bounded a, Ord a, PathPiece a) => Button a where - label :: a -> Widget - label = toWidget . toPathPiece - - cssClass :: a -> ButtonCssClass - cssClass _ = BCDefault - - - data BtnDelete = BtnDelete | BtnAbort deriving (Enum, Eq, Ord, Bounded, Read, Show) @@ -111,27 +70,13 @@ instance PathPiece BtnDelete where -- for displaying the button only, not rea toPathPiece = showToPathPiece fromPathPiece = readFromPathPiece -instance Button BtnDelete where +instance Button UniWorX BtnDelete where label BtnDelete = [whamlet|_{MsgBtnDelete}|] label BtnAbort = [whamlet|_{MsgBtnAbort}|] cssClass BtnDelete = BCDanger cssClass BtnAbort = BCDefault - -data SubmitButton = BtnSubmit - deriving (Enum, Eq, Ord, Bounded, Read, Show) - -instance PathPiece SubmitButton where - toPathPiece = showToPathPiece - fromPathPiece = readFromPathPiece - -instance Button SubmitButton where - label BtnSubmit = [whamlet|_{MsgBtnSubmit}|] - - cssClass BtnSubmit = BCPrimary - - data RegisterButton = BtnRegister | BtnDeregister deriving (Enum, Eq, Ord, Bounded, Read, Show) @@ -139,7 +84,7 @@ instance PathPiece RegisterButton where toPathPiece = showToPathPiece fromPathPiece = readFromPathPiece -instance Button RegisterButton where +instance Button UniWorX RegisterButton where label BtnRegister = [whamlet|_{MsgBtnRegister}|] label BtnDeregister = [whamlet|_{MsgBtnDeregister}|] @@ -153,7 +98,7 @@ instance PathPiece AdminHijackUserButton where toPathPiece = showToPathPiece fromPathPiece = readFromPathPiece -instance Button AdminHijackUserButton where +instance Button UniWorX AdminHijackUserButton where label BtnHijack = [whamlet|_{MsgBtnHijack}|] cssClass BtnHijack = BCDefault @@ -166,7 +111,7 @@ instance Button AdminHijackUserButton where -- instance PathPiece LinkButton where -- LinkButton route = ??? -linkButton :: Widget -> ButtonCssClass -> Route UniWorX -> Widget +linkButton :: Widget -> ButtonCssClass UniWorX -> Route UniWorX -> Widget linkButton lbl cls url = [whamlet| ^{lbl} |] -- [whamlet| --
@@ -178,30 +123,6 @@ linkButton lbl cls url = [whamlet| Route UniWorX -> Widget simpleLink lbl url = [whamlet| ^{lbl} |] -buttonField :: Button a => a -> Field Handler a -- already validates that the correct button press was received (result only neccessary for combinedButtonField) -buttonField btn = Field {fieldParse, fieldView, fieldEnctype} - where - fieldEnctype = UrlEncoded - - fieldView fid name attrs _val _ = - [whamlet| -