Merge branch 'master' into feat/exercises

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

package.yaml

@@ -91,7 +91,6 @@ library:
       - -Wall
       - -fwarn-tabs
       - -O0
-      - -ddump-splices
       cpp-options: -DDEVELOPMENT
     else:
       ghc-options:

shell.nix

@@ -1,4 +1,4 @@
-{ nixpkgs ? import <nixpkgs> {}, compiler ? "ghc802" }:
+{ nixpkgs ? import <nixpkgs> {}, 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
+      cleanup() {
-      ret=$?
+          pg_ctl stop -D ''${pgDir}
+          rm -rvf ''${pgDir} ''${pgSockDir} ''${pgLogFile}
+      }
 
-      pg_ctl stop -D ''${pgDir}
+      trap cleanup EXIT
-      rm -rvf ''${pgDir} ''${pgSockDir} ''${pgLogFile}
-      exit ''${ret}
     '';
   };
 

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 =
+registerButton registered = renderAForm FormStandard $       
-    renderBootstrap3  bsHorizontalDefault $       
       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)

src/Handler/Home.bak

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

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

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 $ (,)
+  ((uploadResult, uploadWidget), uploadEnctype) <- runFormPost . renderAForm FormStandard $ (,)
-    <$> areq checkBoxField (bfs ("Dies sind Korrekturen" :: Text)) (Just False)
+    <$> areq checkBoxField "Dies sind Korrekturen" (Just False)
-    <*> fileAFormReq (bfs ("Archiv" :: Text))
+    <*> fileAFormReq "Archiv"
-    <*  bootstrapSubmit ("Mehrere Hochladen" :: BootstrapSubmit Text)
+    <*  submitButton
 
   runDB $ do
     case uploadResult of
@@ -211,10 +211,10 @@ getSubmissionR = postSubmissionR
 postSubmissionR cID = do
   submissionId <- decrypt cID
   
-  ((uploadResult, uploadWidget), uploadEnctype) <- runFormPost . renderBootstrap3 BootstrapBasicForm $ (,)
+  ((uploadResult, uploadWidget), uploadEnctype) <- runFormPost . renderAForm FormStandard $ (,)
-    <$> areq checkBoxField (bfs ("Dies ist eine Korrektur" :: Text)) (Just False)
+    <$> areq checkBoxField "Dies ist eine Korrektur" (Just False)
-    <*> fileAFormReq (bfs ("Datei" :: Text))
+    <*> fileAFormReq "Datei"
-    <*  bootstrapSubmit ("Upload" :: BootstrapSubmit Text)
+    <*  submitButton
 
   (submission, files) <- runDB $ do
     submission <- do

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)

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

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
 

src/Handler/Utils/Bootstrap3.hs

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

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
     

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

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:
+  - location:
-    git: https://github.com/pngwjpgh/zip-stream.git
+      git: https://github.com/pngwjpgh/zip-stream.git
-    commit: 9272bbed000928d500febad1cdc98d1da29d399e
+      commit: 9272bbed000928d500febad1cdc98d1da29d399e
-  extra-dep: true
+    extra-dep: true
-- location:
+  - location:
-    git: https://github.com/mlitchard/yesod-auth-ldap.git
+      git: https://github.com/mlitchard/yesod-auth-ldap.git
-    commit: 69e08ef687ab96df3352ff4267562135453c6f02
+      commit: 69e08ef687ab96df3352ff4267562135453c6f02
-  extra-dep: true
+    extra-dep: true
-- location:
+  - location:
-    git: https://github.com/mlitchard/authenticate-ldap.git
+      git: https://github.com/mlitchard/authenticate-ldap.git
-    commit: cc2770024766a8fa29d3086688df60aaf65fb954
+      commit: cc2770024766a8fa29d3086688df60aaf65fb954
-  extra-dep: true
+    extra-dep: true
+  - location:
+      git: https://github.com/pngwjpgh/encoding.git
+      commit: 67bb87ceff53f0178c988dd4e15eeb2daee92b84
+    extra-dep: true
+
 extra-deps:
-- colonnade-1.1.1
+  - colonnade-1.2.0
-- yesod-colonnade-1.1.0
+  - yesod-colonnade-1.2.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
 
-- encoding-0.8.2
+  - conduit-resumablesink-0.2
-- regex-compat-0.93.1
 
-- LDAP-0.6.11
+  - uuid-crypto-1.4.0.0
-resolver: lts-9.3
+  - filepath-crypto-0.1.0.0
-allow-newer: true
+  - cryptoids-0.5.0.0
+  - cryptoids-types-0.0.0
+  - cryptoids-class-0.0.0
+
+  - LDAP-0.6.11
+
+resolver: lts-10.5

templates/form.hamlet

@@ -0,0 +1,9 @@
+$newline never
+#{fragment}
+$case formLayout
+  $of FormStandard
+    $forall view <- views
+      <div :fvRequired view:.required :not $ fvRequired view:.optional :isJust $ fvErrors view:.has-error>
+        $if not (Blaze.null $ fvLabel view)
+          <label for=#{fvId view}>#{fvLabel view}
+        ^{fvInput view}