Framework for custom LDAP

config/settings.yml

@@ -35,10 +35,13 @@ database:
   poolsize: "_env:PGPOOLSIZE:10"
 
 ldap:
-  uri:      "_env:LDAPURI:ldap://localhost:389"
+  host:     "_env:LDAPHOST:"
-  dn:       "_env:LDAPDN:uniworx"
+  tls:      "_env:LDAPTLS:"
-  password: "_env:LDAPPW:"
+  port:     "_env:LDAPPORT:389"
-  basename: "_env:LDAPBN:"
+  user:     "_env:LDAPUSER:"
+  pass:     "_env:LDAPPASS:"
+  baseDN:   "_env:LDAPBASE:"
+  scope:    "_env:LDAPSCOPE:WholeSubtree"
 
 default-favourites: 12
 default-theme: Default

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

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.

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"

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
+

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 (appSettings -> AppSettings{..}) = catMaybes
-    authPlugins app = [genericAuthLDAP $ ldapConfig app] ++ extraAuthPlugins
+      [ campusLogin <$> appLdapConf
-        -- Enable authDummy login if enabled.
+      , maintenanceLogin <$> appAuthPWFile
-        where extraAuthPlugins = [authDummy | appAuthDummyLogin $ appSettings app]
+      , authDummy <$ guard appAuthDummyLogin
-                              ++ [authPWFile fp | fp <- maybeToList . appAuthPWFile $ appSettings app]
+      ]
+
     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.

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|Ma<i>thema</i>tik|]
   label CreateInf  = "Informatik"
 

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| <a href=@{url} .btn .#{bcc2txt cls} role=button>^{lbl} |]
 --   [whamlet|
 --     <form method=post action=@{url}>
@@ -178,30 +123,6 @@ linkButton lbl cls url = [whamlet| <a href=@{url} .btn .#{bcc2txt cls} role=butt
 simpleLink :: Widget -> Route UniWorX -> Widget
 simpleLink lbl url = [whamlet| <a href=@{url}>^{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|
-        <button .btn .#{bcc2txt $ cssClass btn} type=submit name=#{name} value=#{toPathPiece btn} *{attrs} ##{fid}>^{label btn}
-      |]
-
-    fieldParse []    _ = return $ Right Nothing
-    fieldParse [str] _
-      | str == toPathPiece btn = return $ Right $ Just btn
-      | otherwise  = return $ Left "Wrong button value"
-    fieldParse _ _ = return $ Left "Multiple button values"
-
-
-combinedButtonField :: Button a => [a] -> AForm Handler [Maybe a]
-combinedButtonField btns = traverse b2f btns
-  where
-    b2f b = aopt (buttonField b) "" Nothing
-
-submitButton :: AForm Handler ()
-submitButton = void $ combinedButtonField [BtnSubmit]
 
     {-
 combinedButtonField :: Button a => [a] -> Form m -> Form (a,m)
@@ -236,7 +157,7 @@ combinedButtonField btns inner csrf = do
     -}
 
 -- buttonForm :: Button a => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, (WidgetT UniWorX IO ()))
-buttonForm :: (Button a) => Form a
+buttonForm :: (Button UniWorX a) => Form a
 buttonForm csrf = do
     buttonIdent <- newFormIdent
     let button b = mopt (buttonField b) ("n/a"{ fsName = Just buttonIdent }) Nothing
@@ -444,88 +365,6 @@ fsm = bfs -- TODO: get rid of Bootstrap
 fsb :: Text -> FieldSettings site -- DEPRECATED
 fsb = bfs -- Just to avoid annoying Ambiguous Type Errors
 
-fsl ::  Text -> FieldSettings UniWorX
-fsl lbl =
-  FieldSettings { fsLabel    = (SomeMessage lbl)
-                , fsTooltip  = Nothing
-                , fsId       = Nothing
-                , fsName     = Nothing
-                , fsAttrs    = []
-  }
-
-fslI :: RenderMessage UniWorX msg => msg -> FieldSettings UniWorX
-fslI lbl =
-  FieldSettings { fsLabel    = (SomeMessage lbl)
-                , fsTooltip  = Nothing
-                , fsId       = Nothing
-                , fsName     = Nothing
-                , fsAttrs    = []
-  }
-
-fslp ::  Text -> Text -> FieldSettings UniWorX
-fslp lbl placeholder =
-  FieldSettings { fsLabel    = (SomeMessage lbl)
-                , fsTooltip  = Nothing
-                , fsId       = Nothing
-                , fsName     = Nothing
-                , fsAttrs    = [("placeholder", placeholder)]
-  }
-
-fslpI :: RenderMessage UniWorX msg => msg -> Text -> FieldSettings UniWorX
-fslpI lbl placeholder =
-  FieldSettings { fsLabel    = (SomeMessage lbl)
-                , fsTooltip  = Nothing
-                , fsId       = Nothing
-                , fsName     = Nothing
-                , fsAttrs    = [("placeholder", placeholder)]
-  }
-
-addAttr :: Text -> Text -> FieldSettings site -> FieldSettings site
-addAttr attr valu fs = fs { fsAttrs=newAttrs (fsAttrs fs) }
-  where
-    newAttrs :: [(Text,Text)] -> [(Text,Text)]
-    newAttrs [] = [(attr,valu)]
-    newAttrs (p@(a,v):t)
-      | attr==a   = (a,T.append valu $ cons ' ' v):t
-      | otherwise = p:(newAttrs t)
-
-addAttrs :: Text -> [Text] -> FieldSettings site -> FieldSettings site
-addAttrs attr valus fs = fs { fsAttrs=newAttrs (fsAttrs fs) }
-  where
-    newAttrs :: [(Text,Text)] -> [(Text,Text)]
-    newAttrs [] = [(attr,T.intercalate " " valus)]
-    newAttrs (p@(a,v):t)
-      | attr==a   = (a,T.intercalate " " (v:valus)):t
-      | otherwise = p:(newAttrs t)
-
-addClass :: Text -> FieldSettings site -> FieldSettings site
-addClass = addAttr "class"
-
-addClasses :: [Text] -> FieldSettings site -> FieldSettings site
-addClasses = addAttrs "class"
-
-addName :: Text -> FieldSettings site -> FieldSettings site
-addName nm fs = fs { fsName = Just nm }
-
-addNameClass :: Text -> Text -> FieldSettings site -> FieldSettings site
-addNameClass gName gClass fs = fs { fsName= Just gName, fsAttrs=("class",gClass):(fsAttrs fs) }
-
-addIdClass :: Text -> Text -> FieldSettings site -> FieldSettings site
-addIdClass gId gClass fs = fs { fsId= Just gId, fsAttrs=("class",gClass):(fsAttrs fs) }
-
-
-setClass :: FieldSettings site -> Text -> FieldSettings site -- deprecated
-setClass fs c = fs { fsAttrs=("class",c):(fsAttrs fs) }
-
-setNameClass :: FieldSettings site -> Text -> Text -> FieldSettings site -- deprecated
-setNameClass fs gName gClass = fs { fsName= Just gName, fsAttrs=("class",gClass):(fsAttrs fs) }
-
-setTooltip :: String -> FieldSettings site -> FieldSettings site
-setTooltip tt fs
-  | null tt   = fs { fsTooltip = Nothing }
-  | otherwise = fs { fsTooltip = Just $ fromString tt
-                   , fsAttrs=("data-tooltip",fromString tt):(fsAttrs fs) }
-
 optionsPersistCryptoId :: forall site backend a msg.
                           ( YesodPersist site
                           , PersistQueryRead backend

src/Settings.hs

@@ -3,6 +3,8 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
 {-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE MultiWayIf        #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 -- | Settings are centralized, as much as possible, into this file. This
 -- includes database connection settings, static file locations, etc.
 -- In addition, you can configure a number of different aspects of Yesod
@@ -14,6 +16,7 @@ import           ClassyPrelude.Yesod
 import qualified Control.Exception           as Exception
 import           Data.Aeson                  (Result (..), fromJSON, withObject,
                                               (.!=), (.:?))
+import           Data.Aeson.TH
 import           Data.FileEmbed              (embedFile)
 import           Data.Yaml                   (decodeEither')
 import           Database.Persist.Postgresql (PostgresConf)
@@ -24,6 +27,10 @@ import           Yesod.Default.Util          (WidgetFileSettings,
                                               widgetFileNoReload,
                                               widgetFileReload)
 
+import qualified Data.Text.Encoding as Text
+
+import qualified Ldap.Client as Ldap
+
 import Model
 
 -- | Runtime settings to configure this application. These settings can be
@@ -34,6 +41,7 @@ data AppSettings = AppSettings
     -- ^ Directory from which to serve static files.
     , appDatabaseConf           :: PostgresConf
     -- ^ Configuration settings for accessing the database.
+    , appLdapConf               :: Maybe LdapConf
     , appRoot                   :: Maybe Text
     -- ^ Base for all generated URLs. If @Nothing@, determined
     -- from the request headers.
@@ -45,11 +53,6 @@ data AppSettings = AppSettings
     -- ^ Get the IP address from the header when logging. Useful when sitting
     -- behind a reverse proxy.
 
-    , appLDAPURI                :: String
-    , appLDAPDN                 :: String
-    , appLDAPPw                 :: String
-    , appLDAPBaseName           :: Maybe String
-
     , appDetailedRequestLogging :: Bool
     -- ^ Use detailed request logging system
     , appShouldLogAll           :: Bool
@@ -83,6 +86,33 @@ data AppSettings = AppSettings
 
     }
 
+data LdapConf = LdapConf
+  { ldapHost :: Ldap.Host, ldapPort :: Ldap.PortNumber
+  , ldapDn :: Ldap.Dn, ldapPassword :: Ldap.Password
+  , ldapBase :: Ldap.Dn
+  , ldapScope :: Ldap.Scope
+  }
+
+deriveFromJSON defaultOptions ''Ldap.Scope
+
+instance FromJSON LdapConf where
+    parseJSON = withObject "LdapConf" $ \o -> do
+        ldapTls <- o .:? "tls"
+        tlsSettings <- case ldapTls :: Maybe String of
+          Just spec
+            | spec == "insecure" -> return $ Just Ldap.insecureTlsSettings
+            | spec == "default"  -> return $ Just Ldap.defaultTlsSettings
+            | null spec          -> return Nothing
+          Nothing                -> return Nothing
+          _otherwise             -> fail "Could not parse LDAP TLSSettings"
+        ldapHost <- maybe Ldap.Plain (flip Ldap.Tls) tlsSettings <$> o .: "host"
+        ldapPort <- (fromIntegral :: Int -> Ldap.PortNumber) <$> o .: "port"
+        ldapDn <- Ldap.Dn <$> o .: "user"
+        ldapPassword <- Ldap.Password . Text.encodeUtf8 <$> o .: "pass"
+        ldapBase <- Ldap.Dn <$> o .: "baseDN"
+        ldapScope <- o .: "scope"
+        return LdapConf{..}
+
 instance FromJSON AppSettings where
     parseJSON = withObject "AppSettings" $ \o -> do
         let defaultDev =
@@ -93,14 +123,12 @@ instance FromJSON AppSettings where
 #endif
         appStaticDir              <- o .: "static-dir"
         appDatabaseConf           <- o .: "database"
+        appLdapConf               <- o .:? "ldap"
         appRoot                   <- o .:? "approot"
         appHost                   <- fromString <$> o .: "host"
         appPort                   <- o .: "port"
         appIpFromHeader           <- o .: "ip-from-header"
 
-        ( appLDAPURI, appLDAPDN, appLDAPPw, appLDAPBaseName )
-          <- (=<< o .: "ldap") . withObject "LDAP" $ \obj -> (,,,) <$> obj .: "uri" <*> obj .: "dn" <*> obj .: "password" <*> obj .:? "basename"
-
         appDetailedRequestLogging <- o .:? "detailed-logging" .!= defaultDev
         appShouldLogAll           <- o .:? "should-log-all"   .!= defaultDev
         appReloadTemplates        <- o .:? "reload-templates" .!= defaultDev

src/Utils/Form.hs

@@ -0,0 +1,193 @@
+{-# LANGUAGE NoImplicitPrelude
+           , TemplateHaskell
+           , ViewPatterns
+           , OverloadedStrings
+           , QuasiQuotes
+           , TemplateHaskell
+           , MultiParamTypeClasses
+           , TypeFamilies
+           , FlexibleContexts
+           , NamedFieldPuns
+           , ScopedTypeVariables
+#-}
+
+module Utils.Form where
+
+import ClassyPrelude.Yesod
+import Settings
+
+import qualified Text.Blaze.Internal as Blaze (null)
+import qualified Data.Text as T
+import qualified Data.Char as Char
+
+import Web.PathPieces
+
+-------------------
+-- 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)
+
+--------------------
+-- Field Settings --
+--------------------
+
+fsl ::  Text -> FieldSettings site
+fsl lbl =
+  FieldSettings { fsLabel    = (SomeMessage lbl)
+                , fsTooltip  = Nothing
+                , fsId       = Nothing
+                , fsName     = Nothing
+                , fsAttrs    = []
+  }
+
+fslI :: RenderMessage site msg => msg -> FieldSettings site
+fslI lbl =
+  FieldSettings { fsLabel    = (SomeMessage lbl)
+                , fsTooltip  = Nothing
+                , fsId       = Nothing
+                , fsName     = Nothing
+                , fsAttrs    = []
+  }
+
+fslp ::  Text -> Text -> FieldSettings site
+fslp lbl placeholder =
+  FieldSettings { fsLabel    = (SomeMessage lbl)
+                , fsTooltip  = Nothing
+                , fsId       = Nothing
+                , fsName     = Nothing
+                , fsAttrs    = [("placeholder", placeholder)]
+  }
+
+fslpI :: RenderMessage site msg => msg -> Text -> FieldSettings site
+fslpI lbl placeholder =
+  FieldSettings { fsLabel    = (SomeMessage lbl)
+                , fsTooltip  = Nothing
+                , fsId       = Nothing
+                , fsName     = Nothing
+                , fsAttrs    = [("placeholder", placeholder)]
+  }
+
+addAttr :: Text -> Text -> FieldSettings site -> FieldSettings site
+addAttr attr valu fs = fs { fsAttrs=newAttrs (fsAttrs fs) }
+  where
+    newAttrs :: [(Text,Text)] -> [(Text,Text)]
+    newAttrs [] = [(attr,valu)]
+    newAttrs (p@(a,v):t)
+      | attr==a   = (a,T.append valu $ cons ' ' v):t
+      | otherwise = p:(newAttrs t)
+
+addAttrs :: Text -> [Text] -> FieldSettings site -> FieldSettings site
+addAttrs attr valus fs = fs { fsAttrs=newAttrs (fsAttrs fs) }
+  where
+    newAttrs :: [(Text,Text)] -> [(Text,Text)]
+    newAttrs [] = [(attr,T.intercalate " " valus)]
+    newAttrs (p@(a,v):t)
+      | attr==a   = (a,T.intercalate " " (v:valus)):t
+      | otherwise = p:(newAttrs t)
+
+addClass :: Text -> FieldSettings site -> FieldSettings site
+addClass = addAttr "class"
+
+addClasses :: [Text] -> FieldSettings site -> FieldSettings site
+addClasses = addAttrs "class"
+
+addName :: Text -> FieldSettings site -> FieldSettings site
+addName nm fs = fs { fsName = Just nm }
+
+addNameClass :: Text -> Text -> FieldSettings site -> FieldSettings site
+addNameClass gName gClass fs = fs { fsName= Just gName, fsAttrs=("class",gClass):(fsAttrs fs) }
+
+addIdClass :: Text -> Text -> FieldSettings site -> FieldSettings site
+addIdClass gId gClass fs = fs { fsId= Just gId, fsAttrs=("class",gClass):(fsAttrs fs) }
+
+
+setClass :: FieldSettings site -> Text -> FieldSettings site -- deprecated
+setClass fs c = fs { fsAttrs=("class",c):(fsAttrs fs) }
+
+setNameClass :: FieldSettings site -> Text -> Text -> FieldSettings site -- deprecated
+setNameClass fs gName gClass = fs { fsName= Just gName, fsAttrs=("class",gClass):(fsAttrs fs) }
+
+setTooltip :: String -> FieldSettings site -> FieldSettings site
+setTooltip tt fs
+  | null tt   = fs { fsTooltip = Nothing }
+  | otherwise = fs { fsTooltip = Just $ fromString tt
+                   , fsAttrs=("data-tooltip",fromString tt):(fsAttrs fs) }
+------------------------------------------------
+-- Unique Form Identifiers to avoid accidents --
+------------------------------------------------
+
+data FormIdentifier = FIDcourse | FIDsheet | FIDsubmission | FIDsettings | FIDcorrectors | FIDcorrectorTable | FIDcorrection | FIDcorrectionsUpload | FIDcorrectionUpload
+  deriving (Enum, Eq, Ord, Bounded, Read, Show)
+
+instance PathPiece FormIdentifier where
+  fromPathPiece = readFromPathPiece
+  toPathPiece = showToPathPiece
+
+
+identForm :: (Monad m, PathPiece ident)
+          => ident -- ^ Form identification
+          -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
+          -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
+identForm = identifyForm . toPathPiece
+
+{- Hinweise zur Erinnerung:
+  - identForm primär, wenn es mehr als ein Formular pro Handler gibt
+  - nur einmal pro makeForm reicht
+-}
+
+----------------------------
+-- Buttons (new version ) --
+----------------------------
+
+data family ButtonCssClass site :: *
+
+bcc2txt :: Show (ButtonCssClass site) => ButtonCssClass site -> 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 site a where
+  label :: a -> WidgetT site IO ()
+  label = toWidget . toPathPiece
+
+  cssClass :: a -> ButtonCssClass site
+
+data SubmitButton = BtnSubmit
+  deriving (Enum, Eq, Ord, Bounded, Read, Show)
+
+instance PathPiece SubmitButton where
+  toPathPiece   = showToPathPiece
+  fromPathPiece = readFromPathPiece
+
+buttonField :: forall site a. (Button site a, Show (ButtonCssClass site)) => a -> Field (HandlerT site IO) 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 _ = let
+      cssClass' :: ButtonCssClass site
+      cssClass' = cssClass btn
+      in [whamlet|
+        <button .btn .#{bcc2txt cssClass'} type=submit name=#{name} value=#{toPathPiece btn} *{attrs} ##{fid}>^{label btn}
+      |]
+
+    fieldParse []    _ = return $ Right Nothing
+    fieldParse [str] _
+      | str == toPathPiece btn = return $ Right $ Just btn
+      | otherwise  = return $ Left "Wrong button value"
+    fieldParse _ _ = return $ Left "Multiple button values"
+
+combinedButtonField :: (Button site a, Show (ButtonCssClass site)) => [a] -> AForm (HandlerT site IO) [Maybe a]
+combinedButtonField btns = traverse b2f btns
+  where
+    b2f b = aopt (buttonField b) "" Nothing
+
+submitButton :: (Button site SubmitButton, Show (ButtonCssClass site)) => AForm (HandlerT site IO) ()
+submitButton = void $ combinedButtonField [BtnSubmit]
+

stack.yaml

@@ -13,27 +13,17 @@ packages:
       git: https://github.com/pngwjpgh/zip-stream.git
       commit: 9272bbed000928d500febad1cdc98d1da29d399e
     extra-dep: true
-  - location:
-      git: https://github.com/mlitchard/yesod-auth-ldap.git
-      commit: 69e08ef687ab96df3352ff4267562135453c6f02
-    extra-dep: true
-  - location:
-      git: https://github.com/mlitchard/authenticate-ldap.git
-      commit: cc2770024766a8fa29d3086688df60aaf65fb954
-    extra-dep: true
   - location:
       git: https://github.com/pngwjpgh/encoding.git
       commit: 67bb87ceff53f0178c988dd4e15eeb2daee92b84
     extra-dep: true
-  - location:
-      git: https://github.com/pngwjpgh/system-locale.git
-      commit: d803ce3607ac6813ac1a065acb423220f57dab3c
-    extra-dep: true
 
 extra-deps:
   - colonnade-1.2.0
   - yesod-colonnade-1.2.0
 
+  - ldap-client-0.2.0
+
   - conduit-resumablesink-0.2
 
   - uuid-crypto-1.4.0.0
@@ -42,6 +32,6 @@ extra-deps:
   - cryptoids-types-0.0.0
   - cryptoids-class-0.0.0
 
-  - LDAP-0.6.11
+  - system-locale-0.3.0.0
 
 resolver: lts-10.5

templates/widgets/campus-login-form.hamlet

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

templates/widgets/campus-login.hamlet

@@ -0,0 +1,11 @@
+^{csrf}
+<table>
+  <tr>
+    <th>_{MsgCampusIdent}
+    <td>^{fvInput identView}
+  <tr>
+    <th>_{MsgCampusPassword}
+    <td>^{fvInput passwordView}
+  <tr>
+    <td colspan="2" style="text-align: right">
+      <button type="submit">_{MsgCampusSubmit}