diff --git a/fill-db.hs b/fill-db.hs index 8810d6aa5..41631aebb 100755 --- a/fill-db.hs +++ b/fill-db.hs @@ -30,7 +30,7 @@ main = db $ do , termHolidays = [fromGregorian 2017 12 24..fromGregorian 2018 01 06] , termLectureStart = fromGregorian 2017 10 16 , termLectureEnd = fromGregorian 2018 02 10 - , termActive = False + , termActive = True } void . insert $ Term { termName = summer2018 @@ -68,4 +68,4 @@ main = db $ do void . insert $ DegreeCourse ifiMsc ffp void . insert $ Lecturer gkleen ffp void . insert $ Corrector gkleen ffp (ByProportion 1) - void . insert $ Sheet ffp "Blatt 1" NotGraded Nothing now now Nothing Nothing now now gkleen gkleen + void . insert $ Sheet ffp "Blatt 1" Nothing NotGraded Nothing now now Nothing Nothing now now gkleen gkleen diff --git a/package.yaml b/package.yaml index aa46feb3e..fb495c5a8 100644 --- a/package.yaml +++ b/package.yaml @@ -91,7 +91,6 @@ library: - -Wall - -fwarn-tabs - -O0 - - -ddump-splices cpp-options: -DDEVELOPMENT else: ghc-options: diff --git a/shell.nix b/shell.nix index c5b561eaa..1274430f9 100644 --- a/shell.nix +++ b/shell.nix @@ -1,4 +1,4 @@ -{ nixpkgs ? import {}, compiler ? "ghc802" }: +{ nixpkgs ? import {}, compiler ? "ghc822" }: let inherit (nixpkgs) pkgs; @@ -22,7 +22,7 @@ let ''; override = oldAttrs: { - nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ postgresql ]) ++ (with haskellPackages; [ stack yesod-bin ]); + nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ postgresql cabal-install ]) ++ (with haskellPackages; [ stack yesod-bin ]); shellHook = '' ${oldAttrs.shellHook} export PROMPT_INFO="${oldAttrs.name}" @@ -36,12 +36,12 @@ let psql -f ${postgresSchema} postgres printf "Postgres logfile is %s\nPostgres socket directory is %s\n" ''${pgLogFile} ''${pgSockDir} - env --unset=shellHook zsh - ret=$? + cleanup() { + pg_ctl stop -D ''${pgDir} + rm -rvf ''${pgDir} ''${pgSockDir} ''${pgLogFile} + } - pg_ctl stop -D ''${pgDir} - rm -rvf ''${pgDir} ''${pgSockDir} ''${pgLogFile} - exit ''${ret} + trap cleanup EXIT ''; }; diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 77c42835f..c8ca18323 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -74,7 +74,7 @@ getCourseListTermR tidini = do -- defaultLayout $ do setTitle "Semesterkurse" linkButton "Neuen Kurs anlegen" BCPrimary CourseEditR - encodeHeadedWidgetTable tableDefault colonnadeTerms courses -- (map entityVal courses) + encodeWidgetTable tableDefault colonnadeTerms courses -- (map entityVal courses) getCourseShowR :: TermId -> Text -> Handler Html getCourseShowR tid csh = do @@ -97,8 +97,7 @@ getCourseShowR tid csh = do $(widgetFile "course") registerButton :: Bool -> Form () -registerButton registered = - renderBootstrap3 bsHorizontalDefault $ +registerButton registered = renderAForm FormStandard $ pure () <* bootstrapSubmit regMsg where msg = if registered then "Abmelden" else "Anmelden" @@ -267,7 +266,7 @@ newCourseForm template = identForm FIDcourse $ \html -> do -- courseId <- runMaybeT $ do -- cid <- cfCourseId template -- UUID.encrypt cidKey cid - (result, widget) <- flip (renderBootstrap3 bsHorizontalDefault) html $ CourseForm + (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm -- <$> pure cid -- $ join $ cfCourseId <$> template -- why doesnt this work? <$> aopt hiddenField "KursId" (cfCourseId <$> template) <*> areq textField (fsb "Name") (cfName <$> template) diff --git a/src/Handler/Home.bak b/src/Handler/Home.bak deleted file mode 100644 index 11dec1ca5..000000000 --- a/src/Handler/Home.bak +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -module Handler.Home where - -import Import -import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3) -import Text.Julius (RawJS (..)) - --- Define our data that will be used for creating the form. -data FileForm = FileForm - { fileInfo :: FileInfo - , fileDescription :: Text - } - --- This is a handler function for the GET request method on the HomeR --- resource pattern. All of your resource patterns are defined in --- config/routes --- --- The majority of the code you will write in Yesod lives in these handler --- functions. You can spread them across multiple files if you are so --- inclined, or create a single monolithic file. -getHomeR :: Handler Html -getHomeR = do - (formWidget, formEnctype) <- generateFormPost sampleForm - let submission = Nothing :: Maybe FileForm - handlerName = "getHomeR" :: Text - defaultLayout $ do - let (commentFormId, commentTextareaId, commentListId) = commentIds - aDomId <- newIdent - setTitle "Welcome To Yesod!" - $(widgetFile "homepage") - -postHomeR :: Handler Html -postHomeR = do - ((result, formWidget), formEnctype) <- runFormPost sampleForm - let handlerName = "postHomeR" :: Text - submission = case result of - FormSuccess res -> Just res - _ -> Nothing - - defaultLayout $ do - let (commentFormId, commentTextareaId, commentListId) = commentIds - aDomId <- newIdent - setTitle "Welcome To Yesod!" - $(widgetFile "homepage") - -sampleForm :: Form FileForm -sampleForm = renderBootstrap3 BootstrapBasicForm $ FileForm - <$> fileAFormReq "Choose a file" - <*> areq textField textSettings Nothing - -- Add attributes like the placeholder and CSS classes. - where textSettings = FieldSettings - { fsLabel = "What's on the file?" - , fsTooltip = Nothing - , fsId = Nothing - , fsName = Nothing - , fsAttrs = - [ ("class", "form-control") - , ("placeholder", "File description") - ] - } - -commentIds :: (Text, Text, Text) -commentIds = ("js-commentForm", "js-createCommentTextarea", "js-commentList") diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 28bacf0b3..06a7d8fb1 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -17,7 +17,6 @@ import Handler.Utils.Zip -- import Data.Time import qualified Data.Text as T -- import Data.Function ((&)) -import Yesod.Form.Bootstrap3 -- import Colonnade -- hiding (fromMaybe) import Yesod.Colonnade @@ -54,7 +53,7 @@ makeSheetForm :: CourseId -> Maybe SheetForm -> Form SheetForm makeSheetForm cid template = identForm FIDsheet $ \html -> do -- TODO: Yesod.Form.MassInput.inputList arbeitet Server-seitig :( -- Erstmal nur mit ZIP arbeiten - (result, widget) <- flip (renderBootstrap3 bsHorizontalDefault) html $ SheetForm + (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm <$> areq textField (fsb "Name") (sfName <$> template) <*> aopt htmlField (fsb "Hinweise für Teilnehmer") (sfMarkingText <$> template) <*> sheetTypeAFormReq (fsb "Bewertung") (sfType <$> template) @@ -129,7 +128,7 @@ getSheetList courseEnt = do setTitle $ toHtml $ T.append "Übungsblätter " csh if null sheets then [whamlet|Es wurden noch keine Übungsblätter angelegt.|] - else encodeHeadedWidgetTable tableDefault colSheets sheets + else encodeWidgetTable tableDefault colSheets sheets -- Show single sheet getSheetShowR :: TermId -> Text -> Text -> Handler Html diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index d7d3cf468..3fb482691 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -13,7 +13,7 @@ module Handler.Submission where import Import hiding (joinPath) -import Yesod.Form.Bootstrap3 +-- import Yesod.Form.Bootstrap3 import Handler.Utils @@ -72,10 +72,10 @@ submissionTable = do getSubmissionListR, postSubmissionListR :: Handler Html getSubmissionListR = postSubmissionListR postSubmissionListR = do - ((uploadResult, uploadWidget), uploadEnctype) <- runFormPost . renderBootstrap3 BootstrapBasicForm $ (,) - <$> areq checkBoxField (bfs ("Dies sind Korrekturen" :: Text)) (Just False) - <*> fileAFormReq (bfs ("Archiv" :: Text)) - <* bootstrapSubmit ("Mehrere Hochladen" :: BootstrapSubmit Text) + ((uploadResult, uploadWidget), uploadEnctype) <- runFormPost . renderAForm FormStandard $ (,) + <$> areq checkBoxField "Dies sind Korrekturen" (Just False) + <*> fileAFormReq "Archiv" + <* submitButton runDB $ do case uploadResult of @@ -211,10 +211,10 @@ getSubmissionR = postSubmissionR postSubmissionR cID = do submissionId <- decrypt cID - ((uploadResult, uploadWidget), uploadEnctype) <- runFormPost . renderBootstrap3 BootstrapBasicForm $ (,) - <$> areq checkBoxField (bfs ("Dies ist eine Korrektur" :: Text)) (Just False) - <*> fileAFormReq (bfs ("Datei" :: Text)) - <* bootstrapSubmit ("Upload" :: BootstrapSubmit Text) + ((uploadResult, uploadWidget), uploadEnctype) <- runFormPost . renderAForm FormStandard $ (,) + <$> areq checkBoxField "Dies ist eine Korrektur" (Just False) + <*> fileAFormReq "Datei" + <* submitButton (submission, files) <- runDB $ do submission <- do diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index aafa70cd7..e41e24fc3 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -69,7 +69,7 @@ getTermShowR = do ] defaultLayout $ do setTitle "Freigeschaltete Semester" - encodeHeadedWidgetTable tableDefault colonnadeTerms termData + encodeWidgetTable tableDefault colonnadeTerms termData getTermEditR :: Handler Html @@ -128,7 +128,7 @@ wdgtTermForm formWidget formEnctype = do newTermForm :: Maybe Term -> Form Term newTermForm template html = do - (result, widget) <- flip (renderBootstrap3 bsHorizontalDefault) html $ Term + (result, widget) <- flip (renderAForm FormStandard) html $ Term <$> areq termNewField (bfs ("Semester" :: Text)) (termName <$> template) <*> areq dayField (bfs ("Erster Tag" :: Text)) (termStart <$> template) <*> areq dayField (bfs ("Letzer Tag" :: Text)) (termEnd <$> template) diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 7ac3bd00c..df9175e4f 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -41,5 +41,5 @@ getUsersR = do -- ++ map (\school -> headed (text2widget $ schoolName $ entityVal school) (\u -> "xx")) schools defaultLayout $ do setTitle "Comprehensive User List" - let userList = encodeHeadedWidgetTable tableDefault colonnadeUsers users + let userList = encodeWidgetTable tableDefault colonnadeUsers users $(widgetFile "users") diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 8f43426b3..e8143d998 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -11,7 +11,6 @@ import Import.NoFoundation import Handler.Utils.DateTime as Handler.Utils import Handler.Utils.Term as Handler.Utils -import Handler.Utils.Bootstrap3 as Handler.Utils import Handler.Utils.Form as Handler.Utils import Handler.Utils.Table as Handler.Utils diff --git a/src/Handler/Utils/Bootstrap3.hs b/src/Handler/Utils/Bootstrap3.hs deleted file mode 100644 index cbc970061..000000000 --- a/src/Handler/Utils/Bootstrap3.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} - -module Handler.Utils.Bootstrap3 where - -import Import -import Data.String (IsString(..)) --- import Yesod.Core --- import qualified Data.Text as T --- import Yesod.Form.Types --- import Yesod.Form.Functions -import Yesod.Form.Bootstrap3 - -bsSubmit :: String -> BootstrapSubmit Text -bsSubmit msg = - BootstrapSubmit (fromString msg) " btn-default btn-primary " [] - -bsHorizontalDefault :: BootstrapFormLayout -bsHorizontalDefault = - BootstrapHorizontalForm - { bflLabelOffset = ColSm 1 - , bflLabelSize = ColSm 4 - , bflInputOffset = ColSm 1 - , bflInputSize = ColSm 6 - } - diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 6b8a2166b..a1df7d94f 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -6,6 +6,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} module Handler.Utils.Form where @@ -22,6 +23,8 @@ 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) ------------------------------------------------ @@ -35,6 +38,18 @@ data FormIdentifier = FIDcourse | FIDsheet identForm :: FormIdentifier -> Form a -> Form a identForm fid = identifyForm (T.pack $ show fid) +------------------- +-- 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 "form") + return (res, widget) ---------------------------- -- Buttons (new version ) -- @@ -70,6 +85,18 @@ instance Button StandardButton where cssClass BtnDelete = BCWarning cssClass BtnAbort = BCDefault cssClass BtnSave = BCPrimary + +data SubmitButton = BtnSubmit + deriving (Enum, Eq, Ord, Bounded, Read, Show) + +instance PathPiece SubmitButton where + toPathPiece = showToPathPiece + fromPathPiece = readFromPathPiece + +instance Button SubmitButton where + label BtnSubmit = "Submit" + + cssClass BtnSubmit = BCPrimary -- -- Looks like a button, but is just a link (e.g. for create course, etc.) -- data LinkButton = LinkButton (Route UniWorX) @@ -108,7 +135,10 @@ buttonField btn = Field {fieldParse, fieldView, fieldEnctype} combinedButtonField1 :: Button a => [a] -> AForm Handler [Maybe a] combinedButtonField1 btns = traverse b2f btns where - b2f b = aopt (buttonField b) "n/a" Nothing + b2f b = aopt (buttonField b) "" Nothing + +submitButton :: AForm Handler () +submitButton = void $ combinedButtonField1 [BtnSubmit] {- combinedButtonField :: Button a => [a] -> Form m -> Form (a,m) @@ -200,7 +230,7 @@ defaultFormActions = [ formBtnDelete postButtonForm :: Text -> Form () postButtonForm lblId = identifyForm lblId buttonF where - buttonF = renderBootstrap3 BootstrapInlineForm $ pure () <* bootstrapSubmit bProps + buttonF = renderAForm FormStandard $ pure () <* bootstrapSubmit bProps bProps :: BootstrapSubmit Text bProps = fromString $ unpack lblId diff --git a/src/Handler/Utils/Table.hs b/src/Handler/Utils/Table.hs index 786bb6357..e2aca0bb4 100644 --- a/src/Handler/Utils/Table.hs +++ b/src/Handler/Utils/Table.hs @@ -36,7 +36,7 @@ pairColonnade a b = mconcat [ lmap fst a, lmap snd b] -- Table Modification encodeHeadedWidgetTableNumbered :: Attribute -> Colonnade Headed a (WidgetT site IO ()) -> [a] -> WidgetT site IO () encodeHeadedWidgetTableNumbered attrs colo tdata = - encodeHeadedWidgetTable attrs (mconcat [numberCol, lmap snd colo]) (zip [1..] tdata) + encodeWidgetTable attrs (mconcat [numberCol, lmap snd colo]) (zip [1..] tdata) where numberCol :: Colonnade Headed (Int,a) (WidgetT site IO ()) numberCol = headed "Nr" (fromString.show.fst) @@ -86,5 +86,5 @@ headedRowSelector toExternal fromExternal attrs colonnade tdata = do collectResult (FormSuccess x:rs) = (x :) <$> collectResult rs return ( catMaybes <$> collectResult selectionResults - , encodeHeadedCellTable attrs (pairColonnade selColonnade colonnade) (zip [0..] tdata) + , encodeCellTable attrs (pairColonnade selColonnade colonnade) (zip [0..] tdata) ) diff --git a/stack.yaml b/stack.yaml index 8cb20da7f..180aa43b0 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,5 @@ flags: {} + docker: enable: false image: uniworx @@ -6,35 +7,40 @@ nix: packages: [] pure: false shell-file: ./stack.nix + extra-package-dbs: [] + packages: -- . -- location: - 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/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 + extra-deps: -- colonnade-1.1.1 -- yesod-colonnade-1.1.0 -# - zip-stream-0.1.0.1 -- conduit-resumablesink-0.2 -- uuid-crypto-1.4.0.0 -- filepath-crypto-0.1.0.0 -- cryptoids-0.5.0.0 -- cryptoids-types-0.0.0 -- cryptoids-class-0.0.0 + - colonnade-1.2.0 + - yesod-colonnade-1.2.0 -- encoding-0.8.2 -- regex-compat-0.93.1 + - conduit-resumablesink-0.2 -- LDAP-0.6.11 -resolver: lts-9.3 -allow-newer: true + - uuid-crypto-1.4.0.0 + - filepath-crypto-0.1.0.0 + - cryptoids-0.5.0.0 + - cryptoids-types-0.0.0 + - cryptoids-class-0.0.0 + + - LDAP-0.6.11 + +resolver: lts-10.5 diff --git a/templates/form.hamlet b/templates/form.hamlet new file mode 100644 index 000000000..b1e3cd9ee --- /dev/null +++ b/templates/form.hamlet @@ -0,0 +1,9 @@ +$newline never +#{fragment} +$case formLayout + $of FormStandard + $forall view <- views +
+ $if not (Blaze.null $ fvLabel view) +